diff --git a/appsrc/Evaluate.hs b/appsrc/Evaluate.hs --- a/appsrc/Evaluate.hs +++ b/appsrc/Evaluate.hs @@ -8,6 +8,8 @@ import NLP.Corpora.Parsing import NLP.POS (eval, loadTagger) +import NLP.Types (POSTagger, RawTag, unTS) +import qualified NLP.Corpora.Brown as B main :: IO () main = do @@ -15,10 +17,10 @@ let modelFile = args!!0 corpora = tail args putStrLn "Loading model..." - tagger <- loadTagger modelFile + tagger <- (loadTagger modelFile:: IO (POSTagger B.Tag)) putStrLn "...model loaded." rawCorpus <- mapM T.readFile corpora let taggedCorpora = map readPOS $ concatMap T.lines $ rawCorpus result = eval tagger taggedCorpora putStrLn ("Result: " ++ show result) - putStrLn ("Tokens tagged: "++(show $ length $ concat taggedCorpora)) + putStrLn ("Tokens tagged: "++(show $ length $ concatMap unTS taggedCorpora)) diff --git a/appsrc/Tagger.hs b/appsrc/Tagger.hs --- a/appsrc/Tagger.hs +++ b/appsrc/Tagger.hs @@ -7,13 +7,16 @@ import System.Environment (getArgs) import NLP.POS (tagText, loadTagger) +import NLP.Types (RawTag, POSTagger) +import qualified NLP.Corpora.Brown as B + main :: IO () main = do args <- getArgs let modelFile = args!!0 sentence = args!!1 putStrLn "Loading model..." - tagger <- loadTagger modelFile + tagger <- (loadTagger modelFile:: IO (POSTagger B.Tag)) putStrLn "...model loaded." T.putStrLn $ tagText tagger (T.pack sentence) diff --git a/appsrc/Trainer.hs b/appsrc/Trainer.hs --- a/appsrc/Trainer.hs +++ b/appsrc/Trainer.hs @@ -10,13 +10,20 @@ import qualified NLP.POS.UnambiguousTagger as UT import NLP.POS (saveTagger, train) import NLP.Corpora.Parsing +import NLP.Types (POSTagger, RawTag) +import qualified NLP.Corpora.Brown as B + main :: IO () main = do args <- getArgs let output = last args corpora = init args + + avgPerTagger :: POSTagger B.Tag avgPerTagger = Avg.mkTagger Avg.emptyPerceptron Nothing + + initTagger :: POSTagger B.Tag initTagger = UT.mkTagger Map.empty (Just avgPerTagger) rawCorpus <- mapM T.readFile corpora let taggedCorpora = map readPOS $ concatMap T.lines $ rawCorpus diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,39 @@ += 0.3.0.0 = + + - Changed the Sentence and TaggedSentence data types to be actual + tree structures with real types at the respective + layers. ChunkedSentence and ChunkOr were also added to facilitate + phrase and clause chunking. + + - Added a POS Tag data type for Brown corpus tags, and a Chunk type for + Chunks as well (in the Brown module, but that's probably not the best + place, given that the chunks have nothing to do with the actual Brown + corpus.) + + - Updated the Parsec Examples to use the typed tags/chunks. + + - Regenerated the defaultTager, it uses the Brown tags now instead of + RawTag. + += 0.2.0.1 = + + - I realized immediately after the 0.2.0.0 release that I broke the + defaultTagger by adding the protectTerms function to the + LiteralTagger. Things broke because (i) there are bugs in that + functionality, which uses run-time assembled regexes, and (ii) the + UnambiguousTagger used in the defaultTagger delegates to an instance + of the LiteralTagger, which pulled in the (semi-broken) protectTerms + function. This has been fixed by replacing the tokenizer when the + LiteralTagger is used as an UnambiguousTagger -- the later tager + doesn't need the functionality, and it should never have been used + there anyway. + + - Added a bevy of tests to cover the above fix. + + - Added tests (currently breaking) that exercise the broken bits of + the protectTerms function. + += 0.2.0.0 = + + - Added support for expressing information extraciton patterns via Parsec. + - Misc. bug fixes. diff --git a/chatter.cabal b/chatter.cabal --- a/chatter.cabal +++ b/chatter.cabal @@ -1,5 +1,5 @@ name: chatter -version: 0.2.0.1 +version: 0.3.0.0 synopsis: A library of simple NLP algorithms. description: chatter is a collection of simple Natural Language Processing algorithms. @@ -24,6 +24,7 @@ maintainer: creswick@gmail.com Cabal-Version: >=1.10 build-type: Simple +Extra-Source-Files: changelog.md data-files: ./data/models/README ./data/models/brown-train.model.gz @@ -44,8 +45,13 @@ NLP.POS.LiteralTagger NLP.POS.UnambiguousTagger NLP.Types + NLP.Types.General + NLP.Types.Tags + NLP.Types.Tree + NLP.Tokenize.Chatter NLP.Corpora.Parsing NLP.Corpora.Email + NLP.Corpora.Brown NLP.Similarity.VectorSim NLP.Extraction.Parsec NLP.Extraction.Examples.ParsecExamples @@ -73,7 +79,10 @@ regex-base, regex-tdfa >= 1.2.0, regex-tdfa-text, - array + array, + QuickCheck < 2.6, + quickcheck-instances + ghc-options: -Wall diff --git a/data/models/brown-train.model.gz b/data/models/brown-train.model.gz # file too large to diff: data/models/brown-train.model.gz diff --git a/src/NLP/Corpora/Brown.hs b/src/NLP/Corpora/Brown.hs new file mode 100644 --- /dev/null +++ b/src/NLP/Corpora/Brown.hs @@ -0,0 +1,673 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} +-- | The internal implementation of critical types in terms of the +-- Brown corpus. +module NLP.Corpora.Brown + ( Tag(..) + , Chunk(..) + ) +where + +import Data.Serialize (Serialize) +import qualified Data.Text as T +import Data.Text (Text) +import Text.Read (readMaybe) +import Test.QuickCheck.Arbitrary (Arbitrary(..)) +import Test.QuickCheck.Gen (elements) + +import GHC.Generics + +import qualified NLP.Types.Tags as T +import NLP.Types.General + +data Chunk = C_NP -- ^ Noun Phrase. + | C_VP -- ^ Verb Phrase. + | C_PP -- ^ Prepositional Phrase. + | C_CL -- ^ Clause. + deriving (Read, Show, Ord, Eq, Generic, Enum) + +instance Arbitrary Chunk where + arbitrary = elements [C_NP ..] + +instance Serialize Chunk + +instance Serialize Tag + +instance T.Tag Tag where + fromTag = showBrownTag + + parseTag txt = case parseBrownTag txt of + Left _ -> Unk + Right t -> t + + -- | Constant tag for "unknown" + tagUNK = Unk + + tagTerm = showBrownTag + +instance Arbitrary Tag where + arbitrary = elements [Op_Paren ..] + +parseBrownTag :: Text -> Either Error Tag +parseBrownTag "(" = Right Op_Paren +parseBrownTag ")" = Right Cl_Paren +parseBrownTag "*" = Right Negator +parseBrownTag "," = Right Comma +parseBrownTag "-" = Right Dash +parseBrownTag "." = Right Term +parseBrownTag ":" = Right Colon +parseBrownTag txt = + let normalized = replaceAll tagTxtPatterns (T.toUpper txt) + in case readMaybe $ T.unpack normalized of + Nothing -> Left (T.append "Could not parse: " txt) + Just t -> Right t + + +-- | Order matters here: The patterns are replaced in reverse order +-- when generating tags, and in top-to-bottom when generating tags. +tagTxtPatterns :: [(Text, Text)] +tagTxtPatterns = [ ("-", "_") + , ("+", "_pl_") + , ("*", "star") + , ("$", "dollar") + ] + +reversePatterns :: [(Text, Text)] +reversePatterns = map (\(x,y) -> (y,x)) tagTxtPatterns + +showBrownTag :: Tag -> Text +showBrownTag Op_Paren = "(" +showBrownTag Cl_Paren = ")" +showBrownTag Negator = "*" +showBrownTag Comma = "," +showBrownTag Dash = "-" +showBrownTag Term = "." +showBrownTag Colon = ":" +showBrownTag tag = replaceAll reversePatterns (T.pack $ show tag) + +replaceAll :: [(Text, Text)] -> (Text -> Text) +replaceAll patterns = foldl (.) id (map (uncurry T.replace) patterns) + +instance T.ChunkTag Chunk where + fromChunk = T.pack . show + +data Tag = Op_Paren -- ^ ( + | Cl_Paren -- ^ ) + | Negator -- ^ *, not n't + | Comma -- ^ , + | Dash -- ^ - + | Term -- ^ . Sentence Terminator + | Colon -- ^ : + | ABL -- ^ determiner/pronoun, pre-qualifier e.g.; quite such + -- rather + | ABN -- ^ determiner/pronoun, pre-quantifier e.g.; all half + -- many nary + | ABX -- ^ determiner/pronoun, double conjunction or + -- pre-quantifier both + | AP -- ^ determiner/pronoun, post-determiner many other next + -- more last former little several enough most least + -- only very few fewer past same Last latter less single + -- plenty 'nough lesser certain various manye + -- next-to-last particular final previous present nuf + | APdollar -- ^ determiner/pronoun, post-determiner, genitive + -- e.g.; other's + | AP_pl_AP -- ^ determiner/pronoun, post-determiner, + -- hyphenated pair e.g.; many-much + | AT -- ^ article e.g.; the an no a every th' ever' ye + | BE -- ^ verb "to be", infinitive or imperative e.g.; be + | BED -- ^ verb "to be", past tense, 2nd person singular or + -- all persons plural e.g.; were + | BEDstar -- ^ verb "to be", past tense, 2nd person singular + -- or all persons plural, negated e.g.; weren't + | BEDZ -- ^ verb "to be", past tense, 1st and 3rd person + -- singular e.g.; was + | BEDZstar -- ^ verb "to be", past tense, 1st and 3rd person + -- singular, negated e.g.; wasn't + | BEG -- ^ verb "to be", present participle or gerund e.g.; + -- being + | BEM -- ^ verb "to be", present tense, 1st person singular + -- e.g.; am + | BEMstar -- ^ verb "to be", present tense, 1st person + -- singular, negated e.g.; ain't + | BEN -- ^ verb "to be", past participle e.g.; been + | BER -- ^ verb "to be", present tense, 2nd person singular + -- or all persons plural e.g.; are art + | BERstar -- ^ verb "to be", present tense, 2nd person + -- singular or all persons plural, negated e.g.; + -- aren't ain't + | BEZ -- ^ verb "to be", present tense, 3rd person singular + -- e.g.; is + | BEZstar -- ^ verb "to be", present tense, 3rd person + -- singular, negated e.g.; isn't ain't + | CC -- ^ conjunction, coordinating e.g.; and or but plus & + -- either neither nor yet 'n' and/or minus an' + | CD -- ^ numeral, cardinal e.g.; two one 1 four 2 1913 71 74 + -- 637 1937 8 five three million 87-31 29-5 seven 1,119 + -- fifty-three 7.5 billion hundred 125,000 1,700 60 100 + -- six ... + | CDdollar -- ^ numeral, cardinal, genitive e.g.; 1960's + -- 1961's .404's + | CS -- ^ conjunction, subordinating e.g.; that as after + -- whether before while like because if since for than + -- altho until so unless though providing once lest + -- s'posin' till whereas whereupon supposing tho' albeit + -- then so's 'fore + | DO -- ^ verb "to do", uninflected present tense, infinitive + -- or imperative e.g.; do dost + | DOstar -- ^ verb "to do", uninflected present tense or + -- imperative, negated e.g.; don't + | DO_pl_PPSS -- ^ verb "to do", past or present tense + + -- pronoun, personal, nominative, not 3rd person + -- singular e.g.; d'you + | DOD -- ^ verb "to do", past tense e.g.; did done + | DODstar -- ^ verb "to do", past tense, negated e.g.; didn't + | DOZ -- ^ verb "to do", present tense, 3rd person singular + -- e.g.; does + | DOZstar -- ^ verb "to do", present tense, 3rd person + -- singular, negated e.g.; doesn't don't + | DT -- ^ determiner/pronoun, singular e.g.; this each + -- another that 'nother + | DTdollar -- ^ determiner/pronoun, singular, genitive e.g.; + -- another's + | DT_pl_BEZ -- ^ determiner/pronoun + verb "to be", present + -- tense, 3rd person singular e.g.; that's + | DT_pl_MD -- ^ determiner/pronoun + modal auxillary e.g.; + -- that'll this'll + | DTI -- ^ determiner/pronoun, singular or plural e.g.; any + -- some + | DTS -- ^ determiner/pronoun, plural e.g.; these those them + | DTS_pl_BEZ -- ^ pronoun, plural + verb "to be", present + -- tense, 3rd person singular e.g.; them's + | DTX -- ^ determiner, pronoun or double conjunction e.g.; + -- neither either one + | EX -- ^ existential there e.g.; there + | EX_pl_BEZ -- ^ existential there + verb "to be", present + -- tense, 3rd person singular e.g.; there's + | EX_pl_HVD -- ^ existential there + verb "to have", past + -- tense e.g.; there'd + | EX_pl_HVZ -- ^ existential there + verb "to have", present + -- tense, 3rd person singular e.g.; there's + | EX_pl_MD -- ^ existential there + modal auxillary e.g.; + -- there'll there'd + | FW_star -- ^ foreign word: negator e.g.; pas non ne + | FW_AT -- ^ foreign word: article e.g.; la le el un die der + -- ein keine eine das las les Il + | FW_AT_pl_NN -- ^ foreign word: article + noun, singular, + -- common e.g.; l'orchestre l'identite l'arcade + -- l'ange l'assistance l'activite L'Universite + -- l'independance L'Union L'Unita l'osservatore + | FW_AT_pl_NP -- ^ foreign word: article + noun, singular, + -- proper e.g.; L'Astree L'Imperiale + | FW_BE -- ^ foreign word: verb "to be", infinitive or + -- imperative e.g.; sit + | FW_BER -- ^ foreign word: verb "to be", present tense, 2nd + -- person singular or all persons plural e.g.; sind + -- sunt etes + | FW_BEZ -- ^ foreign word: verb "to be", present tense, 3rd + -- person singular e.g.; ist est + | FW_CC -- ^ foreign word: conjunction, coordinating e.g.; et + -- ma mais und aber och nec y + | FW_CD -- ^ foreign word: numeral, cardinal e.g.; une cinq + -- deux sieben unam zwei + | FW_CS -- ^ foreign word: conjunction, subordinating e.g.; + -- bevor quam ma + | FW_DT -- ^ foreign word: determiner/pronoun, singular e.g.; + -- hoc + | FW_DT_pl_BEZ -- ^ foreign word: determiner + verb "to be", + -- present tense, 3rd person singular e.g.; + -- c'est + | FW_DTS -- ^ foreign word: determiner/pronoun, plural e.g.; + -- haec + | FW_HV -- ^ foreign word: verb "to have", present tense, not + -- 3rd person singular e.g.; habe + | FW_IN -- ^ foreign word: preposition e.g.; ad de en a par + -- con dans ex von auf super post sine sur sub avec + -- per inter sans pour pendant in di + | FW_IN_pl_AT -- ^ foreign word: preposition + article e.g.; + -- della des du aux zur d'un del dell' + | FW_IN_pl_NN -- ^ foreign word: preposition + noun, + -- singular, common e.g.; d'etat d'hotel + -- d'argent d'identite d'art + | FW_IN_pl_NP -- ^ foreign word: preposition + noun, + -- singular, proper e.g.; d'Yquem d'Eiffel + | FW_JJ -- ^ foreign word: adjective e.g.; avant Espagnol + -- sinfonica Siciliana Philharmonique grand publique + -- haute noire bouffe Douce meme humaine bel + -- serieuses royaux anticus presto Sovietskaya + -- Bayerische comique schwarzen ... + | FW_JJR -- ^ foreign word: adjective, comparative e.g.; + -- fortiori + | FW_JJT -- ^ foreign word: adjective, superlative e.g.; + -- optimo + | FW_NN -- ^ foreign word: noun, singular, common e.g.; + -- ballet esprit ersatz mano chatte goutte sang + -- Fledermaus oud def kolkhoz roi troika canto boite + -- blutwurst carne muzyka bonheur monde piece force + -- ... + | FW_NNdollar -- ^ foreign word: noun, singular, common, + -- genitive e.g.; corporis intellectus arte's + -- dei aeternitatis senioritatis curiae + -- patronne's chambre's + | FW_NNS -- ^ foreign word: noun, plural, common e.g.; al + -- culpas vopos boites haflis kolkhozes augen + -- tyrannis alpha-beta-gammas metis banditos rata + -- phis negociants crus Einsatzkommandos kamikaze + -- wohaws sabinas zorrillas palazzi engages coureurs + -- corroborees yori Ubermenschen ... + | FW_NP -- ^ foreign word: noun, singular, proper e.g.; + -- Karshilama Dieu Rundfunk Afrique Espanol Afrika + -- Spagna Gott Carthago deus + | FW_NPS -- ^ foreign word: noun, plural, proper e.g.; + -- Svenskarna Atlantes Dieux + | FW_NR -- ^ foreign word: noun, singular, adverbial e.g.; + -- heute morgen aujourd'hui hoy + | FW_OD -- ^ foreign word: numeral, ordinal e.g.; 18e 17e + -- quintus + | FW_PN -- ^ foreign word: pronoun, nominal e.g.; hoc + | FW_PPdollar -- ^ foreign word: determiner, possessive e.g.; + -- mea mon deras vos + | FW_PPL -- ^ foreign word: pronoun, singular, reflexive + -- e.g.; se + | FW_PPL_pl_VBZ -- ^ foreign word: pronoun, singular, + -- reflexive + verb, present tense, 3rd + -- person singular e.g.; s'excuse s'accuse + | FW_PPO -- ^ pronoun, personal, accusative e.g.; lui me moi + -- mi + | FW_PPO_pl_IN -- ^ foreign word: pronoun, personal, + -- accusative + preposition e.g.; mecum tecum + | FW_PPS -- ^ foreign word: pronoun, personal, nominative, + -- 3rd person singular e.g.; il + | FW_PPSS -- ^ foreign word: pronoun, personal, nominative, + -- not 3rd person singular e.g.; ich vous sie je + | FW_PPSS_pl_HV -- ^ foreign word: pronoun, personal, + -- nominative, not 3rd person singular + verb + -- "to have", present tense, not 3rd person + -- singular e.g.; j'ai + | FW_QL -- ^ foreign word: qualifier e.g.; minus + | FW_RB -- ^ foreign word: adverb e.g.; bas assai deja um + -- wiederum cito velociter vielleicht simpliciter non + -- zu domi nuper sic forsan olim oui semper tout + -- despues hors + | FW_RB_pl_CC -- ^ foreign word: adverb + conjunction, + -- coordinating e.g.; forisque + | FW_TO_pl_VB -- ^ foreign word: infinitival to + verb, + -- infinitive e.g.; d'entretenir + | FW_UH -- ^ foreign word: interjection e.g.; sayonara bien + -- adieu arigato bonjour adios bueno tchalo ciao o + | FW_VB -- ^ foreign word: verb, present tense, not 3rd + -- person singular, imperative or infinitive e.g.; + -- nolo contendere vive fermate faciunt esse vade + -- noli tangere dites duces meminisse iuvabit + -- gosaimasu voulez habla ksu'u'peli'afo lacheln + -- miuchi say allons strafe portant + | FW_VBD -- ^ foreign word: verb, past tense e.g.; stabat + -- peccavi audivi + | FW_VBG -- ^ foreign word: verb, present participle or + -- gerund e.g.; nolens volens appellant + -- seq. obliterans servanda dicendi delenda + | FW_VBN -- ^ foreign word: verb, past participle e.g.; vue + -- verstrichen rasa verboten engages + | FW_VBZ -- ^ foreign word: verb, present tense, 3rd person + -- singular e.g.; gouverne sinkt sigue diapiace + | FW_WDT -- ^ foreign word: WH-determiner e.g.; quo qua quod + -- que quok + | FW_WPO -- ^ foreign word: WH-pronoun, accusative e.g.; + -- quibusdam + | FW_WPS -- ^ foreign word: WH-pronoun, nominative e.g.; qui + | HV -- ^ verb "to have", uninflected present tense, + -- infinitive or imperative e.g.; have hast + | HVstar -- ^ verb "to have", uninflected present tense or + -- imperative, negated e.g.; haven't ain't + | HV_pl_TO -- ^ verb "to have", uninflected present tense + + -- infinitival to e.g.; hafta + | HVD -- ^ verb "to have", past tense e.g.; had + | HVDstar -- ^ verb "to have", past tense, negated e.g.; + -- hadn't + | HVG -- ^ verb "to have", present participle or gerund e.g.; + -- having + | HVN -- ^ verb "to have", past participle e.g.; had + | HVZ -- ^ verb "to have", present tense, 3rd person singular + -- e.g.; has hath + | HVZstar -- ^ verb "to have", present tense, 3rd person + -- singular, negated e.g.; hasn't ain't + | IN -- ^ preposition e.g.; of in for by considering to on + -- among at through with under into regarding than since + -- despite according per before toward against as after + -- during including between without except upon out over + -- ... + | IN_pl_IN -- ^ preposition, hyphenated pair e.g.; f'ovuh + | IN_pl_PPO -- ^ preposition + pronoun, personal, accusative + -- e.g.; t'hi-im + | JJ -- ^ adjective e.g.; recent over-all possible + -- hard-fought favorable hard meager fit such widespread + -- outmoded inadequate ambiguous grand clerical + -- effective orderly federal foster general + -- proportionate ... + | JJdollar -- ^ adjective, genitive e.g.; Great's + | JJ_pl_JJ -- ^ adjective, hyphenated pair e.g.; big-large + -- long-far + | JJR -- ^ adjective, comparative e.g.; greater older further + -- earlier later freer franker wider better deeper + -- firmer tougher faster higher bigger worse younger + -- lighter nicer slower happier frothier Greater newer + -- Elder ... + | JJR_pl_CS -- ^ adjective + conjunction, coordinating e.g.; + -- lighter'n + | JJS -- ^ adjective, semantically superlative e.g.; top + -- chief principal northernmost master key head main + -- tops utmost innermost foremost uppermost paramount + -- topmost + | JJT -- ^ adjective, superlative e.g.; best largest coolest + -- calmest latest greatest earliest simplest strongest + -- newest fiercest unhappiest worst youngest worthiest + -- fastest hottest fittest lowest finest smallest + -- staunchest ... + | MD -- ^ modal auxillary e.g.; should may might will would + -- must can could shall ought need wilt + | MDstar -- ^ modal auxillary, negated e.g.; cannot couldn't + -- wouldn't can't won't shouldn't shan't mustn't + -- musn't + | MD_pl_HV -- ^ modal auxillary + verb "to have", uninflected + -- form e.g.; shouldda musta coulda must've woulda + -- could've + | MD_pl_PPSS -- ^ modal auxillary + pronoun, personal, + -- nominative, not 3rd person singular e.g.; + -- willya + | MD_pl_TO -- ^ modal auxillary + infinitival to e.g.; oughta + | NN -- ^ noun, singular, common e.g.; failure burden court + -- fire appointment awarding compensation Mayor interim + -- committee fact effect airport management surveillance + -- jail doctor intern extern night weekend duty + -- legislation Tax Office ... + | NNdollar -- ^ noun, singular, common, genitive e.g.; + -- season's world's player's night's chapter's + -- golf's football's baseball's club's U.'s + -- coach's bride's bridegroom's board's county's + -- firm's company's superintendent's mob's Navy's + -- ... + | NN_pl_BEZ -- ^ noun, singular, common + verb "to be", + -- present tense, 3rd person singular e.g.; + -- water's camera's sky's kid's Pa's heat's + -- throat's father's money's undersecretary's + -- granite's level's wife's fat's Knife's fire's + -- name's hell's leg's sun's roulette's cane's + -- guy's kind's baseball's ... + | NN_pl_HVD -- ^ noun, singular, common + verb "to have", + -- past tense e.g.; Pa'd + | NN_pl_HVZ -- ^ noun, singular, common + verb "to have", + -- present tense, 3rd person singular e.g.; guy's + -- Knife's boat's summer's rain's company's + | NN_pl_IN -- ^ noun, singular, common + preposition e.g.; + -- buncha + | NN_pl_MD -- ^ noun, singular, common + modal auxillary + -- e.g.; cowhand'd sun'll + | NN_pl_NN -- ^ noun, singular, common, hyphenated pair e.g.; + -- stomach-belly + | NNS -- ^ noun, plural, common e.g.; irregularities + -- presentments thanks reports voters laws legislators + -- years areas adjustments chambers $100 bonds courts + -- sales details raises sessions members congressmen + -- votes polls calls ... + | NNSdollar -- ^ noun, plural, common, genitive e.g.; + -- taxpayers' children's members' States' women's + -- cutters' motorists' steelmakers' hours' + -- Nations' lawyers' prisoners' architects' + -- tourists' Employers' secretaries' Rogues' ... + | NNS_pl_MD -- ^ noun, plural, common + modal auxillary e.g.; + -- duds'd oystchers'll + | NP -- ^ noun, singular, proper e.g.; Fulton Atlanta + -- September-October Durwood Pye Ivan Allen + -- Jr. Jan. Alpharetta Grady William B. Hartsfield Pearl + -- Williams Aug. Berry J. M. Cheshire Griffin Opelika + -- Ala. E. Pelham Snodgrass ... + | NPdollar -- ^ noun, singular, proper, genitive e.g.; + -- Green's Landis' Smith's Carreon's Allison's + -- Boston's Spahn's Willie's Mickey's Milwaukee's + -- Mays' Howsam's Mantle's Shaw's Wagner's + -- Rickey's Shea's Palmer's Arnold's Broglio's ... + | NP_pl_BEZ -- ^ noun, singular, proper + verb "to be", + -- present tense, 3rd person singular e.g.; W.'s + -- Ike's Mack's Jack's Kate's Katharine's Black's + -- Arthur's Seaton's Buckhorn's Breed's Penny's + -- Rob's Kitty's Blackwell's Myra's Wally's + -- Lucille's Springfield's Arlene's + | NP_pl_HVZ -- ^ noun, singular, proper + verb "to have", + -- present tense, 3rd person singular e.g.; + -- Bill's Guardino's Celie's Skolman's Crosson's + -- Tim's Wally's + | NP_pl_MD -- ^ noun, singular, proper + modal auxillary + -- e.g.; Gyp'll John'll + | NPS -- ^ noun, plural, proper e.g.; Chases Aderholds + -- Chapelles Armisteads Lockies Carbones French + -- Marskmen Toppers Franciscans Romans Cadillacs Masons + -- Blacks Catholics British Dixiecrats Mississippians + -- Congresses ... + | NPSdollar -- ^ noun, plural, proper, genitive e.g.; + -- Republicans' Orioles' Birds' Yanks' Redbirds' + -- Bucs' Yankees' Stevenses' Geraghtys' Burkes' + -- Wackers' Achaeans' Dresbachs' Russians' + -- Democrats' Gershwins' Adventists' Negroes' + -- Catholics' ... + | NR -- ^ noun, singular, adverbial e.g.; Friday home + -- Wednesday Tuesday Monday Sunday Thursday yesterday + -- tomorrow tonight West East Saturday west left east + -- downtown north northeast southeast northwest North + -- South right ... + | NRdollar -- ^ noun, singular, adverbial, genitive e.g.; + -- Saturday's Monday's yesterday's tonight's + -- tomorrow's Sunday's Wednesday's Friday's + -- today's Tuesday's West's Today's South's + | NR_pl_MD -- ^ noun, singular, adverbial + modal auxillary + -- e.g.; today'll + | NRS -- ^ noun, plural, adverbial e.g.; Sundays Mondays + -- Saturdays Wednesdays Souths Fridays + | OD -- ^ numeral, ordinal e.g.; first 13th third nineteenth + -- 2d 61st second sixth eighth ninth twenty-first + -- eleventh 50th eighteenth- Thirty-ninth 72nd 1/20th + -- twentieth mid-19th thousandth 350th sixteenth 701st + -- ... + | PN -- ^ pronoun, nominal e.g.; none something everything + -- one anyone nothing nobody everybody everyone anybody + -- anything someone no-one nothin + | PNdollar -- ^ pronoun, nominal, genitive e.g.; one's + -- someone's anybody's nobody's everybody's + -- anyone's everyone's + | PN_pl_BEZ -- ^ pronoun, nominal + verb "to be", present + -- tense, 3rd person singular e.g.; nothing's + -- everything's somebody's nobody's someone's + | PN_pl_HVD -- ^ pronoun, nominal + verb "to have", past + -- tense e.g.; nobody'd + | PN_pl_HVZ -- ^ pronoun, nominal + verb "to have", present + -- tense, 3rd person singular e.g.; nobody's + -- somebody's one's + | PN_pl_MD -- ^ pronoun, nominal + modal auxillary e.g.; + -- someone'll somebody'll anybody'd + | PPdollar -- ^ determiner, possessive e.g.; our its his + -- their my your her out thy mine thine + | PPdollardollar -- ^ pronoun, possessive e.g.; ours mine his + -- hers theirs yours + | PPL -- ^ pronoun, singular, reflexive e.g.; itself himself + -- myself yourself herself oneself ownself + | PPLS -- ^ pronoun, plural, reflexive e.g.; themselves + -- ourselves yourselves + | PPO -- ^ pronoun, personal, accusative e.g.; them it him me + -- us you 'em her thee we'uns + | PPS -- ^ pronoun, personal, nominative, 3rd person singular + -- e.g.; it he she thee + | PPS_pl_BEZ -- ^ pronoun, personal, nominative, 3rd person + -- singular + verb "to be", present tense, 3rd + -- person singular e.g.; it's he's she's + | PPS_pl_HVD -- ^ pronoun, personal, nominative, 3rd person + -- singular + verb "to have", past tense e.g.; + -- she'd he'd it'd + | PPS_pl_HVZ -- ^ pronoun, personal, nominative, 3rd person + -- singular + verb "to have", present tense, 3rd + -- person singular e.g.; it's he's she's + | PPS_pl_MD -- ^ pronoun, personal, nominative, 3rd person + -- singular + modal auxillary e.g.; he'll she'll + -- it'll he'd it'd she'd + | PPSS -- ^ pronoun, personal, nominative, not 3rd person + -- singular e.g.; they we I you ye thou you'uns + | PPSS_pl_BEM -- ^ pronoun, personal, nominative, not 3rd + -- person singular + verb "to be", present + -- tense, 1st person singular e.g.; I'm Ahm + | PPSS_pl_BER -- ^ pronoun, personal, nominative, not 3rd + -- person singular + verb "to be", present + -- tense, 2nd person singular or all persons + -- plural e.g.; we're you're they're + | PPSS_pl_BEZ -- ^ pronoun, personal, nominative, not 3rd + -- person singular + verb "to be", present + -- tense, 3rd person singular e.g.; you's + | PPSS_pl_BEZstar -- ^ pronoun, personal, nominative, not 3rd + -- person singular + verb "to be", present + -- tense, 3rd person singular, negated + -- e.g.; 'tain't + | PPSS_pl_HV -- ^ pronoun, personal, nominative, not 3rd + -- person singular + verb "to have", uninflected + -- present tense e.g.; I've we've they've you've + | PPSS_pl_HVD -- ^ pronoun, personal, nominative, not 3rd + -- person singular + verb "to have", past tense + -- e.g.; I'd you'd we'd they'd + | PPSS_pl_MD -- ^ pronoun, personal, nominative, not 3rd + -- person singular + modal auxillary e.g.; + -- you'll we'll I'll we'd I'd they'll they'd + -- you'd + | PPSS_pl_VB -- ^ pronoun, personal, nominative, not 3rd + -- person singular + verb "to verb", uninflected + -- present tense e.g.; y'know + | QL -- ^ qualifier, pre e.g.; well less very most so real as + -- highly fundamentally even how much remarkably + -- somewhat more completely too thus ill deeply little + -- overly halfway almost impossibly far severly such ... + | QLP -- ^ qualifier, post e.g.; indeed enough still 'nuff + | RB -- ^ adverb e.g.; only often generally also nevertheless + -- upon together back newly no likely meanwhile near + -- then heavily there apparently yet outright fully + -- aside consistently specifically formally ever just + -- ... + | RBdollar -- ^ adverb, genitive e.g.; else's + | RB_pl_BEZ -- ^ adverb + verb "to be", present tense, 3rd + -- person singular e.g.; here's there's + | RB_pl_CS -- ^ adverb + conjunction, coordinating e.g.; + -- well's soon's + | RBR -- ^ adverb, comparative e.g.; further earlier better + -- later higher tougher more harder longer sooner less + -- faster easier louder farther oftener nearer cheaper + -- slower tighter lower worse heavier quicker ... + | RBR_pl_CS -- ^ adverb, comparative + conjunction, + -- coordinating e.g.; more'n + | RBT -- ^ adverb, superlative e.g.; most best highest + -- uppermost nearest brightest hardest fastest deepest + -- farthest loudest ... + | RN -- ^ adverb, nominal e.g.; here afar then + | RP -- ^ adverb, particle e.g.; up out off down over on in + -- about through across after + | RP_pl_IN -- ^ adverb, particle + preposition e.g.; out'n + -- outta + | TO -- ^ infinitival to e.g.; to t' + | TO_pl_VB -- ^ infinitival to + verb, infinitive e.g.; + -- t'jawn t'lah + | UH -- ^ interjection e.g.; Hurrah bang whee hmpf ah goodbye + -- oops oh-the-pain-of-it ha crunch say oh why see well + -- hello lo alas tarantara rum-tum-tum gosh hell keerist + -- Jesus Keeeerist boy c'mon 'mon goddamn bah hoo-pig + -- damn ... + | VB -- ^ verb, base: uninflected present, imperative or + -- infinitive e.g.; investigate find act follow inure + -- achieve reduce take remedy re-set distribute realize + -- disable feel receive continue place protect eliminate + -- elaborate work permit run enter force ... + | VB_pl_AT -- ^ verb, base: uninflected present or infinitive + -- + article e.g.; wanna + | VB_pl_IN -- ^ verb, base: uninflected present, imperative + -- or infinitive + preposition e.g.; lookit + | VB_pl_JJ -- ^ verb, base: uninflected present, imperative + -- or infinitive + adjective e.g.; die-dead + | VB_pl_PPO -- ^ verb, uninflected present tense + pronoun, + -- personal, accusative e.g.; let's lemme gimme + | VB_pl_RP -- ^ verb, imperative + adverbial particle e.g.; + -- g'ahn c'mon + | VB_pl_TO -- ^ verb, base: uninflected present, imperative + -- or infinitive + infinitival to e.g.; wanta + -- wanna + | VB_pl_VB -- ^ verb, base: uninflected present, imperative + -- or infinitive; hypenated pair e.g.; say-speak + | VBD -- ^ verb, past tense e.g.; said produced took + -- recommended commented urged found added praised + -- charged listed became announced brought attended + -- wanted voted defeated received got stood shot + -- scheduled feared promised made ... + | VBG -- ^ verb, present participle or gerund e.g.; + -- modernizing improving purchasing Purchasing lacking + -- enabling pricing keeping getting picking entering + -- voting warning making strengthening setting + -- neighboring attending participating moving ... + | VBG_pl_TO -- ^ verb, present participle + infinitival to + -- e.g.; gonna + | VBN -- ^ verb, past participle e.g.; conducted charged won + -- received studied revised operated accepted combined + -- experienced recommended effected granted seen + -- protected adopted retarded notarized selected + -- composed gotten printed ... + | VBN_pl_TO -- ^ verb, past participle + infinitival to e.g.; + -- gotta + | VBZ -- ^ verb, present tense, 3rd person singular e.g.; + -- deserves believes receives takes goes expires says + -- opposes starts permits expects thinks faces votes + -- teaches holds calls fears spends collects backs + -- eliminates sets flies gives seeks reads ... + | WDT -- ^ WH-determiner e.g.; which what whatever whichever + -- whichever-the-hell + | WDT_pl_BER -- ^ WH-determiner + verb "to be", present + -- tense, 2nd person singular or all persons + -- plural e.g.; what're + | WDT_pl_BER_pl_PP -- ^ WH-determiner + verb "to be", + -- present, 2nd person singular or all + -- persons plural + pronoun, personal, + -- nominative, not 3rd person singular + -- e.g.; whaddya + | WDT_pl_BEZ -- ^ WH-determiner + verb "to be", present + -- tense, 3rd person singular e.g.; what's + | WDT_pl_DO_pl_PPS -- ^ WH-determiner + verb "to do", + -- uninflected present tense + pronoun, + -- personal, nominative, not 3rd person + -- singular e.g.; whaddya + | WDT_pl_DOD -- ^ WH-determiner + verb "to do", past tense + -- e.g.; what'd + | WDT_pl_HVZ -- ^ WH-determiner + verb "to have", present + -- tense, 3rd person singular e.g.; what's + | WPdollar -- ^ WH-pronoun, genitive e.g.; whose whosever + | WPO -- ^ WH-pronoun, accusative e.g.; whom that who + | WPS -- ^ WH-pronoun, nominative e.g.; that who whoever + -- whosoever what whatsoever + | WPS_pl_BEZ -- ^ WH-pronoun, nominative + verb "to be", + -- present, 3rd person singular e.g.; that's + -- who's + | WPS_pl_HVD -- ^ WH-pronoun, nominative + verb "to have", + -- past tense e.g.; who'd + | WPS_pl_HVZ -- ^ WH-pronoun, nominative + verb "to have", + -- present tense, 3rd person singular e.g.; + -- who's that's + | WPS_pl_MD -- ^ WH-pronoun, nominative + modal auxillary + -- e.g.; who'll that'd who'd that'll + | WQL -- ^ WH-qualifier e.g.; however how + | WRB -- ^ WH-adverb e.g.; however when where why whereby + -- wherever how whenever whereon wherein wherewith + -- wheare wherefore whereof howsabout + | WRB_pl_BER -- ^ WH-adverb + verb "to be", present, 2nd + -- person singular or all persons plural e.g.; + -- where're + | WRB_pl_BEZ -- ^ WH-adverb + verb "to be", present, 3rd + -- person singular e.g.; how's where's + | WRB_pl_DO -- ^ WH-adverb + verb "to do", present, not 3rd + -- person singular e.g.; howda + | WRB_pl_DOD -- ^ WH-adverb + verb "to do", past tense e.g.; + -- where'd how'd + | WRB_pl_DODstar -- ^ WH-adverb + verb "to do", past tense, + -- negated e.g.; whyn't + | WRB_pl_DOZ -- ^ WH-adverb + verb "to do", present tense, + -- 3rd person singular e.g.; how's + | WRB_pl_IN -- ^ WH-adverb + preposition e.g.; why'n + | WRB_pl_MD -- ^ WH-adverb + modal auxillary e.g.; where'd + | Unk -- ^ Unknown. + deriving (Read, Show, Ord, Eq, Generic, Enum) diff --git a/src/NLP/Corpora/Parsing.hs b/src/NLP/Corpora/Parsing.hs --- a/src/NLP/Corpora/Parsing.hs +++ b/src/NLP/Corpora/Parsing.hs @@ -4,7 +4,8 @@ import qualified Data.Text as T import Data.Text (Text) -import NLP.Types (Tag(..), parseTag, tagUNK, TaggedSentence) +import NLP.Types (Tag(..), parseTag, tagUNK, TaggedSentence(..) + , POS(..), Token(..)) -- | Read a POS-tagged corpus out of a Text string of the form: -- "token\/tag token\/tag..." @@ -12,14 +13,16 @@ -- >>> readPOS "Dear/jj Sirs/nns :/: Let/vb" -- [("Dear",JJ),("Sirs",NNS),(":",Other ":"),("Let",VB)] -- -readPOS :: Text -> TaggedSentence -readPOS str = map toTagged $ T.words str +readPOS :: Tag t => Text -> TaggedSentence t +readPOS str = readPOSWith parseTag str + +readPOSWith :: Tag t => (Text -> t) -> Text -> TaggedSentence t +readPOSWith parser str = TaggedSent $ map toTagged $ T.words str where - toTagged :: Text -> (Text, Tag) toTagged txt | "/" `T.isInfixOf` txt = let (tok, tagStr) = T.breakOnEnd "/" (T.strip txt) - in (safeInit tok, parseTag tagStr) - | otherwise = (txt, tagUNK) + in POS (parser tagStr) (Token $ safeInit tok) + | otherwise = POS tagUNK (Token txt) -- | Returns all but the last element of a string, unless the string -- is empty, in which case it returns that string. diff --git a/src/NLP/Extraction/Examples/ParsecExamples.hs b/src/NLP/Extraction/Examples/ParsecExamples.hs --- a/src/NLP/Extraction/Examples/ParsecExamples.hs +++ b/src/NLP/Extraction/Examples/ParsecExamples.hs @@ -2,15 +2,15 @@ module NLP.Extraction.Examples.ParsecExamples where import qualified Data.Text as T -import Data.Text (Text) -import Text.Parsec.Prim (parse, (<|>), try) -import Text.Parsec.Pos +import Text.Parsec.Prim ( (<|>), try) import qualified Text.Parsec.Combinator as PC import NLP.Types import NLP.Extraction.Parsec +import qualified NLP.Corpora.Brown as B + -- grammar = r""" -- NP: {+} # Chunk sequences of DT, JJ, NN -- PP: {} # Chunk prepositions followed by NP @@ -18,42 +18,41 @@ -- CLAUSE: {} # Chunk NP, VP -- """ -- cp = nltk.RegexpParser(grammar) --- sentence = [("Mary", "NN"), ("saw", "VBD"), ("the", "DT"), ("cat", "NN"), --- ("sit", "VB"), ("on", "IN"), ("the", "DT"), ("mat", "NN")] - +-- sentence = [("Mary", Tag "NN"), ("saw", Tag "VBD"), ("the", Tag "DT"), ("cat", Tag "NN"), ("sit", Tag "VB"), ("on", Tag "IN"), ("the", Tag "DT"), ("mat", Tag "NN")] +-- sentence = [TaggedSent [POS NP (Token "Mary"),POS VBD (Token "saw"),POS DT (Token "the"),POS NN (Token "cat"),POS VB (Token "sit"),POS IN (Token "on"),POS DT (Token "the"),POS NN (Token "mat"),POS Term (Token ".")]] +-- | Find a clause in a larger collection of text. +-- +-- findClause skips over leading tokens, if needed, to locate a +-- clause. +findClause :: Extractor B.Tag (ChunkOr B.Chunk B.Tag) +findClause = followedBy anyToken clause --- | Create a chunked tag from a set of incomming tagged tokens. -chunk :: [(Text, Tag)] -- ^ The incomming tokens to create a chunk from. - -> Tag -- ^ The tag for the chunk. - -> (Text, Tag) -chunk tss tg = (T.unwords (map fst tss), tg) +clause :: Extractor B.Tag (ChunkOr B.Chunk B.Tag) +clause = do + np <- nounPhrase + vp <- verbPhrase + return $ mkChunk B.C_CL [np, vp] -prepPhrase :: Extractor (Text, Tag) +prepPhrase :: Extractor B.Tag (ChunkOr B.Chunk B.Tag) prepPhrase = do - prep <- posTok $ Tag "IN" + prep <- posTok B.IN np <- nounPhrase - return $ chunk [prep, np] (Tag "p-phr") + return $ mkChunk B.C_PP [POS_CN prep, np] -nounPhrase :: Extractor (Text, Tag) +nounPhrase :: Extractor B.Tag (ChunkOr B.Chunk B.Tag) nounPhrase = do - nlist <- PC.many1 (try (posTok $ Tag "NN") - <|> try (posTok $ Tag "DT") - <|> (posTok $ Tag "JJ")) - let term = T.intercalate " " (map fst nlist) - return (term, Tag "n-phr") - -clause :: Extractor (Text, Tag) -clause = do - np <- nounPhrase - vp <- verbPhrase - return $ chunk [np, vp] $ Tag "clause" + nlist <- PC.many1 (try (posTok $ B.NN) + <|> try (posTok $ B.DT) + <|> try (posTok $ B.AT) -- tagger often gets 'the' wrong. + <|> (posTok $ B.JJ)) + return (mkChunk B.C_NP $ map POS_CN nlist) -- VP: {+$} # Chunk verbs and their arguments -- CLAUSE: {} -verbPhrase :: Extractor (Text, Tag) +verbPhrase :: Extractor B.Tag (ChunkOr B.Chunk B.Tag) verbPhrase = do vp <- posPrefix "V" - obj <- PC.many1 $ ((try nounPhrase) - <|> (try prepPhrase) - <|> clause) - return $ chunk (vp:obj) $ Tag "v-phr" + obj <- PC.many1 $ ((try clause) + <|> (try nounPhrase) + <|> prepPhrase) + return $ mkChunk B.C_VP $ ((POS_CN vp):obj) diff --git a/src/NLP/Extraction/Parsec.hs b/src/NLP/Extraction/Parsec.hs --- a/src/NLP/Extraction/Parsec.hs +++ b/src/NLP/Extraction/Parsec.hs @@ -1,4 +1,6 @@ {-# LANGUAGE OverloadedStrings, RankNTypes, FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} -- | This is a very simple wrapper around Parsec for writing -- Information Extraction patterns. @@ -27,12 +29,21 @@ import Data.Text (Text) import qualified Data.Text as T import Text.Parsec.String () -- required for the `Stream [t] Identity t` instance. -import Text.Parsec.Prim (lookAhead, token, Parsec, try) +import Text.Parsec.Prim (lookAhead, token, Parsec, try, Stream(..)) import qualified Text.Parsec.Combinator as PC import Text.Parsec.Pos (newPos) -import NLP.Types (TaggedSentence, Tag(..), CaseSensitive(..)) +import NLP.Types (TaggedSentence(..), Tag(..), CaseSensitive(..), + POS(..), Token(..)) +instance (Monad m, Tag t) => Stream (TaggedSentence t) m (POS t) where + uncons (TaggedSent ts) = do + mRes <- uncons ts + case mRes of + Nothing -> return $ Nothing + Just (mTok, rest) -> return $ Just (mTok, TaggedSent rest) + {-# INLINE uncons #-} + -- | A Parsec parser. -- -- Example usage: @@ -42,15 +53,15 @@ -- > import Text.Parsec.Prim -- > parse myExtractor "interactive repl" someTaggedSentence -- @ -type Extractor = Parsec TaggedSentence () +type Extractor t = Parsec (TaggedSentence t) () -- | Consume a token with the given POS Tag -posTok :: Tag -> Extractor (Text, Tag) +posTok :: Tag t => t -> Extractor t (POS t) posTok tag = token showTok posFromTok testTok where - showTok (_,t) = show t - posFromTok (_,_) = newPos "unknown" 0 0 - testTok tok@(_,t) = if tag == t then Just tok else Nothing + showTok = show + posFromTok _ = newPos "unknown" 0 0 + testTok tok@(POS t _) = if tag == t then Just tok else Nothing -- | Consume a token with the specified POS prefix. -- @@ -58,37 +69,37 @@ -- > parse (posPrefix "n") "ghci" [("Bob", Tag "np")] -- Right [("Bob", Tag "np")] -- @ -posPrefix :: Text -> Extractor (Text, Tag) +posPrefix :: Tag t => Text -> Extractor t (POS t) posPrefix str = token showTok posFromTok testTok where - showTok (_,t) = show t - posFromTok (_,_) = newPos "unknown" 0 0 - testTok tok@(_,Tag t) = if str `T.isPrefixOf` t then Just tok else Nothing + showTok = show + posFromTok _ = newPos "unknown" 0 0 + testTok tok@(POS t _) = if str `T.isPrefixOf` (tagTerm t) then Just tok else Nothing -- | Text equality matching with optional case sensitivity. -matches :: CaseSensitive -> Text -> Text -> Bool +matches :: CaseSensitive -> Token -> Token -> Bool matches Sensitive x y = x == y -matches Insensitive x y = (T.toLower x) == (T.toLower y) +matches Insensitive (Token x) (Token y) = (T.toLower x) == (T.toLower y) -- | Consume a token with the given lexical representation. -txtTok :: CaseSensitive -> Text -> Extractor (Text, Tag) +txtTok :: Tag t => CaseSensitive -> Token -> Extractor t (POS t) txtTok sensitive txt = token showTok posFromTok testTok where - showTok (t,_) = show t - posFromTok (_,_) = newPos "unknown" 0 0 - testTok tok@(t,_) | matches sensitive txt t = Just tok - | otherwise = Nothing + showTok = show + posFromTok _ = newPos "unknown" 0 0 + testTok tok@(POS _ t) | matches sensitive txt t = Just tok + | otherwise = Nothing -- | Consume any one non-empty token. -anyToken :: Extractor (Text, Tag) +anyToken :: Tag t => Extractor t (POS t) anyToken = token showTok posFromTok testTok where - showTok (txt,_) = show txt - posFromTok (_,_) = newPos "unknown" 0 0 - testTok tok@(txt,_) | txt == "" = Nothing - | otherwise = Just tok + showTok = show + posFromTok _ = newPos "unknown" 0 0 + testTok tok@(POS _ txt) | txt == "" = Nothing + | otherwise = Just tok -oneOf :: CaseSensitive -> [Text] -> Extractor (Text, Tag) +oneOf :: Tag t => CaseSensitive -> [Token] -> Extractor t (POS t) oneOf sensitive terms = PC.choice (map (\t -> try (txtTok sensitive t)) terms) -- | Skips any number of fill tokens, ending with the end parser, and @@ -96,7 +107,7 @@ -- -- This is useful when you know what you're looking for and (for -- instance) don't care what comes first. -followedBy :: Extractor b -> Extractor a -> Extractor a +followedBy :: Tag t => Extractor t b -> Extractor t a -> Extractor t a followedBy fill end = do _ <- PC.manyTill fill (lookAhead end) end diff --git a/src/NLP/POS.hs b/src/NLP/POS.hs --- a/src/NLP/POS.hs +++ b/src/NLP/POS.hs @@ -13,7 +13,7 @@ -- people don't (yet!) use "Data.Text" by default, so there is a -- wrapper around 'tag' that packs and unpacks the 'String'. This is -- innefficient, but it's just to get you started, and 'tagStr' can be --- very handy when you're debugging an tagger in ghci (or cabal repl). +-- very handy when you're debugging a tagger in ghci (or cabal repl). -- -- 'tag' exposes more details of the tokenization and tagging, since -- it returns a list of `TaggedSentence`s, but it doesn't print @@ -52,17 +52,20 @@ import NLP.Corpora.Parsing (readPOS) import NLP.Tokenize.Text (tokenize) -import NLP.Types (POSTagger (..), Sentence, - Tag (..), TaggedSentence, - stripTags, tagUNK) +import NLP.Types ( POSTagger(..), Sentence, POS(..) + , combine, Tag (..), unTS, tsLength + , TaggedSentence(..), stripTags + , tagUNK, printTS) import qualified NLP.POS.AvgPerceptronTagger as Avg import qualified NLP.POS.LiteralTagger as LT import qualified NLP.POS.UnambiguousTagger as UT +import qualified NLP.Corpora.Brown as B + import Paths_chatter -defaultTagger :: IO POSTagger +defaultTagger :: IO (POSTagger B.Tag) defaultTagger = do dir <- getDataDir loadTagger (dir "data" "models" "brown-train.model.gz") @@ -71,7 +74,8 @@ -- tagger packaged with Chatter should have an entry here. By -- convention, the IDs use are the fully qualified module name of the -- tagger package. -taggerTable :: Map ByteString (ByteString -> Maybe POSTagger -> Either String POSTagger) +taggerTable :: Tag t => Map ByteString + (ByteString -> Maybe (POSTagger t) -> Either String (POSTagger t)) taggerTable = Map.fromList [ (LT.taggerID, LT.readTagger) , (Avg.taggerID, Avg.readTagger) @@ -79,7 +83,7 @@ ] -- | Store a `POSTager' to a file. -saveTagger :: POSTagger -> FilePath -> IO () +saveTagger :: Tag t => POSTagger t -> FilePath -> IO () saveTagger tagger file = BS.writeFile file (serialize tagger) -- | Load a tagger, using the interal `taggerTable`. If you need to @@ -89,7 +93,7 @@ -- This function checks the filename to determine if the content -- should be decompressed. If the file ends with ".gz", then we -- assume it is a gziped model. -loadTagger :: FilePath -> IO POSTagger +loadTagger :: Tag t => FilePath -> IO (POSTagger t) loadTagger file = do content <- getContent file case deserialize taggerTable content of @@ -100,7 +104,7 @@ getContent f | ".gz" `isSuffixOf` file = fmap (LBS.toStrict . decompress) $ LBS.readFile f | otherwise = BS.readFile f -serialize :: POSTagger -> ByteString +serialize :: Tag t => POSTagger t -> ByteString serialize tagger = let backoff = case posBackoff tagger of Nothing -> Nothing @@ -110,9 +114,11 @@ , backoff ) -deserialize :: Map ByteString (ByteString -> Maybe POSTagger -> Either String POSTagger) +deserialize :: Tag t => + Map ByteString + (ByteString -> Maybe (POSTagger t) -> Either String (POSTagger t)) -> ByteString - -> Either String POSTagger + -> Either String (POSTagger t) deserialize table bs = do (theID, theTgr, mBackoff) <- decode bs backoff <- case mBackoff of @@ -124,33 +130,18 @@ -- | Tag a chunk of input text with part-of-speech tags, using the -- sentence splitter, tokenizer, and tagger contained in the 'POSTager'. -tag :: POSTagger -> Text -> [TaggedSentence] +tag :: Tag t => POSTagger t -> Text -> [TaggedSentence t] tag p txt = let sentences = (posSplitter p) txt tokens = map (posTokenizer p) sentences in tagTokens p tokens -tagTokens :: POSTagger -> [Sentence] -> [TaggedSentence] +tagTokens :: Tag t => POSTagger t -> [Sentence] -> [TaggedSentence t] tagTokens p tokens = let priority = (posTagger p) tokens in case posBackoff p of Nothing -> priority Just tgr -> combine priority (tagTokens tgr tokens) --- | Combine the results of POS taggers, using the second param to --- fill in 'tagUNK' entries, where possible. -combine :: [TaggedSentence] -> [TaggedSentence] -> [TaggedSentence] -combine xs ys = zipWith combineSentences xs ys - -combineSentences :: TaggedSentence -> TaggedSentence -> TaggedSentence -combineSentences xs ys = zipWith pickTag xs ys - --- | Returns the first param, unless it is tagged 'tagUNK'. --- Throws an error if the text does not match. -pickTag :: (Text, Tag) -> (Text, Tag) -> (Text, Tag) -pickTag a@(txt1, t1) b@(txt2, t2) | txt1 /= txt2 = error ("Text does not match: "++ show a ++ " " ++ show b) - | t1 /= tagUNK = (txt1, t1) - | otherwise = (txt1, t2) - -- | Tag the tokens in a string. -- -- Returns a space-separated string of tokens, each token suffixed @@ -159,28 +150,23 @@ -- >>> tag tagger "the dog jumped ." -- "the/at dog/nn jumped/vbd ./." -- -tagStr :: POSTagger -> String -> String +tagStr :: Tag t => POSTagger t -> String -> String tagStr tgr = T.unpack . tagText tgr . T.pack -- | Text version of tagStr -tagText :: POSTagger -> Text -> Text -tagText tgr str = T.intercalate " " $ map toTaggedTok taggedSents - where - taggedSents = concat $ tag tgr str - - toTaggedTok :: (Text, Tag) -> Text - toTaggedTok (tok, Tag c) = tok `T.append` (T.cons '/' c) +tagText :: Tag t => POSTagger t -> Text -> Text +tagText tgr txt = T.intercalate " " $ map printTS $ tag tgr txt -- | Train a tagger on string input in the standard form for POS -- tagged corpora: -- -- > trainStr tagger "the/at dog/nn jumped/vbd ./." -- -trainStr :: POSTagger -> String -> IO POSTagger +trainStr :: Tag t => POSTagger t -> String -> IO (POSTagger t) trainStr tgr = trainText tgr . T.pack -- | The `Text` version of `trainStr` -trainText :: POSTagger -> Text -> IO POSTagger +trainText :: Tag t => POSTagger t -> Text -> IO (POSTagger t) trainText p exs = train p (map readPOS $ tokenize exs) -- | Train a 'POSTagger' on a corpus of sentences. @@ -200,7 +186,7 @@ -- > let newTagger = APT.mkTagger APT.emptyPerceptron Nothing -- > posTgr <- train newTagger trainingExamples -- -train :: POSTagger -> [TaggedSentence] -> IO POSTagger +train :: Tag t => POSTagger t -> [TaggedSentence t] -> IO (POSTagger t) train p exs = do let trainBackoff = case posBackoff p of @@ -220,13 +206,13 @@ -- -- > |tokens tagged correctly| / |all tokens| -- -eval :: POSTagger -> [TaggedSentence] -> Double +eval :: Tag t => POSTagger t -> [TaggedSentence t] -> Double eval tgr oracle = let sentences = map stripTags oracle results = (posTagger tgr) sentences - totalTokens = fromIntegral $ sum $ map length oracle + totalTokens = fromIntegral $ sum $ map tsLength oracle - isMatch :: (Text, Tag) -> (Text, Tag) -> Double - isMatch (_, rTag) (_, oTag) | rTag == oTag = 1 - | otherwise = 0 - in (sum $ zipWith isMatch (concat results) (concat oracle)) / totalTokens + isMatch :: Tag t => POS t -> POS t -> Double + isMatch (POS rTag _) (POS oTag _) | rTag == oTag = 1 + | otherwise = 0 + in (sum $ zipWith isMatch (concatMap unTS results) (concatMap unTS oracle)) / totalTokens diff --git a/src/NLP/POS/AvgPerceptronTagger.hs b/src/NLP/POS/AvgPerceptronTagger.hs --- a/src/NLP/POS/AvgPerceptronTagger.hs +++ b/src/NLP/POS/AvgPerceptronTagger.hs @@ -19,7 +19,7 @@ ) where -import NLP.Corpora.Parsing (readPOS) +import NLP.Corpora.Parsing (readPOSWith) import NLP.POS.AvgPerceptron ( Perceptron, Feature(..) , Class(..), predict, update , emptyPerceptron, averageWeights) @@ -37,14 +37,14 @@ import qualified Data.Text as T import qualified Data.Text.IO as T -import NLP.Tokenize.Text (tokenize) +import NLP.Tokenize.Chatter (tokenize) import NLP.FullStop (segment) import System.Random.Shuffle (shuffleM) taggerID :: ByteString taggerID = pack "NLP.POS.AvgPerceptronTagger" -readTagger :: ByteString -> Maybe POSTagger -> Either String POSTagger +readTagger :: Tag t => ByteString -> Maybe (POSTagger t) -> Either String (POSTagger t) readTagger bs backoff = do model <- decode bs return $ mkTagger model backoff @@ -56,7 +56,7 @@ -- tokenizer, and Erik Kow's fullstop sentence segmenter -- () as a sentence -- splitter. -mkTagger :: Perceptron -> Maybe POSTagger -> POSTagger +mkTagger :: Tag t => Perceptron -> Maybe (POSTagger t) -> POSTagger t mkTagger per mTgr = POSTagger { posTagger = tag per , posTrainer = \exs -> do newPer <- trainInt itterations per exs @@ -87,17 +87,17 @@ -- >>> tag tagger $ map T.words $ T.lines "Dear sir" -- "Dear/jj Sirs/nns :/: Let/vb" -- -trainNew :: Text -> IO Perceptron -trainNew rawCorpus = train emptyPerceptron rawCorpus +trainNew :: Tag t => (Text -> t) -> Text -> IO Perceptron +trainNew parser rawCorpus = train parser emptyPerceptron rawCorpus -- | Train a new 'Perceptron' on a corpus of files. -trainOnFiles :: [FilePath] -> IO Perceptron -trainOnFiles corpora = foldM step emptyPerceptron corpora +trainOnFiles :: Tag t => (Text -> t) -> [FilePath] -> IO Perceptron +trainOnFiles parser corpora = foldM step emptyPerceptron corpora where step :: Perceptron -> FilePath -> IO Perceptron step per path = do content <- T.readFile path - train per content + train parser per content -- | Add training examples to a perceptron. -- @@ -108,24 +108,25 @@ -- If you're using multiple input files, this can be useful to improve -- performance (by folding over the files). For example, see `trainOnFiles` -- -train :: Perceptron -- ^ The inital model. +train :: Tag t => (Text -> t) -- ^ The POS tag parser. + -> Perceptron -- ^ The inital model. -> Text -- ^ Training data; formatted with one sentence -- per line, and standard POS tags after each -- space-delimeted token. -> IO Perceptron -train per rawCorpus = do - let corpora = map readPOS $ T.lines rawCorpus +train parse per rawCorpus = do + let corpora = map (readPOSWith parse) $ T.lines rawCorpus trainInt itterations per corpora -- | start markers to ensure all features in context are valid, -- even for the first "real" tokens. -startToks :: [Text] -startToks = ["-START-", "-START2-"] +startToks :: [Token] +startToks = [Token "-START-", Token "-START2-"] -- | end markers to ensure all features are valid, even for -- the last "real" tokens. -endToks :: [Text] -endToks = ["-END-", "-END2-"] +endToks :: [Token] +endToks = [Token "-END-", Token "-END2-"] -- | Tag a document (represented as a list of 'Sentence's) with a -- trained 'Perceptron' @@ -154,22 +155,22 @@ -- > prev = tag -- > return tokens -- -tag :: Perceptron -> [Sentence] -> [TaggedSentence] +tag :: Tag t => Perceptron -> [Sentence] -> [TaggedSentence t] tag per corpus = map (tagSentence per) corpus -- | Tag a single sentence. -tagSentence :: Perceptron -> Sentence -> TaggedSentence +tagSentence :: Tag t => Perceptron -> Sentence -> TaggedSentence t tagSentence per sent = let - tags = (map (Class . T.unpack) startToks) ++ map (predictPos per) features + tags = (map tokenToClass startToks) ++ map (predictPos per) features features = zipWith4 (getFeatures sent) [0..] - sent + (tokens sent) (tail tags) tags - in zip sent (map (\(Class c) ->Tag $ T.pack c) $ drop 2 tags) + in applyTags sent (map (\(Class c) -> parseTag $ T.pack c) $ drop 2 tags) -- | Train a model from sentences. -- @@ -202,16 +203,19 @@ -- > open(save_loc, 'wb'), -1) -- > return None -- -trainInt :: Int -- ^ The number of times to iterate over the training +trainInt :: Tag t => + Int -- ^ The number of times to iterate over the training -- data, randomly shuffling after each iteration. (@5@ -- is a reasonable choice.) -> Perceptron -- ^ The 'Perceptron' to train. - -> [TaggedSentence] -- ^ The training data. (A list of @[(Text, Tag)]@'s) + -> [TaggedSentence t] -- ^ The training data. (A list of @[(Text, Tag)]@'s) -> IO Perceptron -- ^ A trained perceptron. IO is needed -- for randomization. -trainInt itr per examples = trainCls itr per $ toClassLst $ map unzip examples +trainInt itr per examples = trainCls itr per $ toClassLst $ map unzipTags examples + -- where + -- toSentPair (xs, ts) = (Sent $ map Token xs, ts) -toClassLst :: [(Sentence, [Tag])] -> [(Sentence, [Class])] +toClassLst :: Tag t => [(Sentence, [t])] -> [(Sentence, [Class])] toClassLst tagged = map (\(x, y)->(x, map (Class . T.unpack . fromTag) y)) tagged trainCls :: Int -> Perceptron -> [(Sentence, [Class])] -> IO Perceptron @@ -219,6 +223,8 @@ trainingSet <- shuffleM $ concat $ take itr $ repeat examples return $ averageWeights $ foldl' trainSentence per trainingSet +tokenToClass :: Token -> Class +tokenToClass = Class . T.unpack . showTok -- | Train on one sentence. -- @@ -237,11 +243,11 @@ trainSentence :: Perceptron -> (Sentence, [Class]) -> Perceptron trainSentence per (sent, ts) = let - tags = (map (Class . T.unpack) startToks) ++ ts ++ (map (Class . T.unpack) endToks) + tags = (map tokenToClass startToks) ++ ts ++ (map tokenToClass endToks) features = zipWith4 (getFeatures sent) [0..] -- index - sent -- words + (tokens sent) -- words (tail tags) -- prev1 tags -- prev2 @@ -285,9 +291,9 @@ -- > add('i+2 word', context[i+2]) -- > return features -- -getFeatures :: [Text] -> Int -> Text -> Class -> Class -> Map Feature Int +getFeatures :: Sentence -> Int -> Token -> Class -> Class -> Map Feature Int getFeatures ctx idx word prev prev2 = let - context = startToks ++ ctx ++ endToks + context = startToks ++ tokens ctx ++ endToks i = idx + length startToks @@ -301,25 +307,21 @@ features :: [[Text]] features = [ ["bias", ""] , ["i suffix", suffix word ] - , ["i pref1", T.take 1 word ] + , ["i pref1", T.take 1 $ showTok word ] , ["i-1 tag", T.pack $ show prev ] , ["i-2 tag", T.pack $ show prev2 ] , ["i tag+i-2 tag", T.pack $ show prev, T.pack $ show prev2 ] - , ["i word", context!!i ] - , ["i-1 tag+i word", T.pack $ show prev, context!!i ] - , ["i-1 word", context!!(i-1) ] - , ["i-1 suffix", suffix (context!!(i-1)) ] - , ["i-2 word", context!!(i-2) ] - , ["i+1 word", context!!(i+1) ] - , ["i+1 suffix", suffix (context!!(i+1)) ] - , ["i+2 word", context!!(i+2) ] + , ["i word", showTok (context!!i) ] + , ["i-1 tag+i word", T.pack $ show prev, showTok (context!!i) ] + , ["i-1 word", showTok (context!!(i-1)) ] + , ["i-1 suffix", suffix (context!!(i-1)) ] + , ["i-2 word", showTok (context!!(i-2)) ] + , ["i+1 word", showTok (context!!(i+1)) ] + , ["i+1 suffix", suffix (context!!(i+1)) ] + , ["i+2 word", showTok (context!!(i+2)) ] ] -- in trace ("getFeatures: "++show (ctx, idx, word, prev, prev2)) $ in foldl' add Map.empty features mkFeature :: Text -> Feature mkFeature txt = Feat $ T.copy txt - -suffix :: Text -> Text -suffix str | T.length str <= 3 = str - | otherwise = T.drop (T.length str - 3) str diff --git a/src/NLP/POS/LiteralTagger.hs b/src/NLP/POS/LiteralTagger.hs --- a/src/NLP/POS/LiteralTagger.hs +++ b/src/NLP/POS/LiteralTagger.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} module NLP.POS.LiteralTagger ( tag @@ -11,9 +10,6 @@ ) where - -import GHC.Generics - import Control.Monad ((>=>)) import Data.Array import Data.ByteString (ByteString) @@ -21,22 +17,21 @@ import Data.Function (on) import Data.List (sortBy) import qualified Data.Map.Strict as Map -import Data.Serialize (Serialize, encode, decode) +import Data.Serialize (encode, decode) import Data.Map.Strict (Map) import Data.Text (Text) import qualified Data.Text as T - -import NLP.Tokenize.Text (Tokenizer, EitherList(..), defaultTokenizer, run) +import NLP.Tokenize.Text (Tokenizer, EitherList(..), defaultTokenizer) +import NLP.Tokenize.Chatter (runTokenizer) import NLP.FullStop (segment) -import NLP.Types ( tagUNK, Sentence, TaggedSentence - , Tag, POSTagger(..), CaseSensitive(..)) +import NLP.Types ( tagUNK, Sentence, TaggedSentence(..), POS(..), applyTags + , Tag, POSTagger(..), CaseSensitive(..), tokens, showTok) import Text.Regex.TDFA import Text.Regex.TDFA.Text (compile) taggerID :: ByteString taggerID = pack "NLP.POS.LiteralTagger" -instance Serialize CaseSensitive -- | Create a Literal Tagger using the specified back-off tagger as a -- fall-back, if one is specified. @@ -44,17 +39,17 @@ -- This uses a tokenizer adapted from the 'tokenize' package for a -- tokenizer, and Erik Kow's fullstop sentence segmenter as a sentence -- splitter. -mkTagger :: Map Text Tag -> CaseSensitive -> Maybe POSTagger -> POSTagger +mkTagger :: Tag t => Map Text t -> CaseSensitive -> Maybe (POSTagger t) -> POSTagger t mkTagger table sensitive mTgr = POSTagger { posTagger = tag (canonicalize table) sensitive , posTrainer = \_ -> return $ mkTagger table sensitive mTgr , posBackoff = mTgr - , posTokenizer = run (protectTerms (Map.keys table) sensitive >=> defaultTokenizer) + , posTokenizer = runTokenizer (protectTerms (Map.keys table) sensitive >=> defaultTokenizer) , posSplitter = (map T.pack) . segment . T.unpack , posSerialize = encode (table, sensitive) , posID = taggerID } - where canonicalize :: Map Text Tag -> Map Text Tag + where canonicalize :: Tag t => Map Text t -> Map Text t canonicalize = case sensitive of Sensitive -> id @@ -122,14 +117,14 @@ -- | True = E [Right x] -- where isUri u = any (`T.isPrefixOf` u) ["http://","ftp://","mailto:"] -tag :: Map Text Tag -> CaseSensitive -> [Sentence] -> [TaggedSentence] +tag :: Tag t => Map Text t -> CaseSensitive -> [Sentence] -> [TaggedSentence t] tag table sensitive ss = map (tagSentence table sensitive) ss -tagSentence :: Map Text Tag -> CaseSensitive -> Sentence -> TaggedSentence -tagSentence table sensitive toks = map findTag toks +tagSentence :: Tag t => Map Text t -> CaseSensitive -> Sentence -> TaggedSentence t +tagSentence table sensitive sent = applyTags sent (map findTag $ tokens sent) where - findTag :: Text -> (Text, Tag) - findTag txt = (txt, Map.findWithDefault tagUNK (canonicalize txt) table) +-- findTag :: Tag t => Token -> t + findTag txt = Map.findWithDefault tagUNK (canonicalize $ showTok txt) table canonicalize :: Text -> Text canonicalize = @@ -139,7 +134,7 @@ -- | deserialization for Literal Taggers. The serialization logic is -- in the posSerialize record of the POSTagger created in mkTagger. -readTagger :: ByteString -> Maybe POSTagger -> Either String POSTagger +readTagger :: Tag t => ByteString -> Maybe (POSTagger t) -> Either String (POSTagger t) readTagger bs backoff = do (model, sensitive) <- decode bs return $ mkTagger model sensitive backoff diff --git a/src/NLP/POS/UnambiguousTagger.hs b/src/NLP/POS/UnambiguousTagger.hs --- a/src/NLP/POS/UnambiguousTagger.hs +++ b/src/NLP/POS/UnambiguousTagger.hs @@ -17,7 +17,7 @@ import Data.Serialize (encode, decode) import Data.Text (Text) -import NLP.Tokenize.Text (defaultTokenizer, run) +import NLP.Tokenize.Chatter (tokenize) import NLP.Types import qualified NLP.POS.LiteralTagger as LT @@ -25,18 +25,18 @@ taggerID :: ByteString taggerID = pack "NLP.POS.UnambiguousTagger" -readTagger :: ByteString -> Maybe POSTagger -> Either String POSTagger +readTagger :: Tag t => ByteString -> Maybe (POSTagger t) -> Either String (POSTagger t) readTagger bs backoff = do model <- decode bs return $ mkTagger model backoff -- | Create an unambiguous tagger, using the supplied 'Map' as a -- source of tags. -mkTagger :: Map Text Tag -> Maybe POSTagger -> POSTagger +mkTagger :: Tag t => Map Text t -> Maybe (POSTagger t) -> POSTagger t mkTagger table mTgr = let litTagger = LT.mkTagger table LT.Sensitive mTgr - trainer :: [TaggedSentence] -> IO POSTagger +-- trainer :: Tag t => [TaggedSentence t] -> IO (POSTagger t) trainer exs = do let newTable = train table exs return $ mkTagger newTable mTgr @@ -44,23 +44,23 @@ in litTagger { posTrainer = trainer , posSerialize = encode table , posID = taggerID - , posTokenizer = run defaultTokenizer + , posTokenizer = tokenize } -- | Trainer method for unambiguous taggers. -train :: Map Text Tag -> [TaggedSentence] -> Map Text Tag +train :: Tag t => Map Text t -> [TaggedSentence t] -> Map Text t train table exs = let - pairs :: [(Text, Tag)] - pairs = concat exs - trainOnPair :: Map Text Tag -> (Text, Tag) -> Map Text Tag - trainOnPair t (txt, tag) = Map.alter (incorporate tag) txt t +-- pairs :: POS t + pairs = concatMap unTS exs - incorporate :: Tag -> Maybe Tag -> Maybe Tag +-- trainOnPair :: Map Text t -> POS t -> Map Text t + trainOnPair t (POS tag (Token txt)) = Map.alter (incorporate tag) txt t + +-- incorporate :: t -> Maybe t -> Maybe t incorporate new Nothing = Just new incorporate new (Just old) | new == old = Just old | otherwise = Just tagUNK -- Forget the tag. in foldl trainOnPair table pairs - diff --git a/src/NLP/Tokenize/Chatter.hs b/src/NLP/Tokenize/Chatter.hs new file mode 100644 --- /dev/null +++ b/src/NLP/Tokenize/Chatter.hs @@ -0,0 +1,15 @@ +module NLP.Tokenize.Chatter + ( runTokenizer + , tokenize + ) +where + +import Data.Text (Text) +import NLP.Tokenize.Text (Tokenizer, defaultTokenizer, run) +import NLP.Types.Tree + +tokenize :: Text -> Sentence +tokenize txt = runTokenizer defaultTokenizer txt + +runTokenizer :: Tokenizer -> (Text -> Sentence) +runTokenizer tok txt = Sent $ map Token (run tok txt) diff --git a/src/NLP/Types.hs b/src/NLP/Types.hs --- a/src/NLP/Types.hs +++ b/src/NLP/Types.hs @@ -1,7 +1,11 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} module NLP.Types + ( module NLP.Types + , module NLP.Types.Tags + , module NLP.Types.General + , module NLP.Types.Tree + ) where import Control.DeepSeq (NFData) @@ -13,31 +17,15 @@ import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as T -import Data.Text.Encoding (encodeUtf8, decodeUtf8) -import GHC.Generics -type Sentence = [Text] -type TaggedSentence = [(Text, Tag)] - -flattenText :: TaggedSentence -> Text -flattenText ts = T.unwords $ map fst ts - --- | True if the input sentence contains the given text token. Does --- not do partial or approximate matching, and compares details in a --- fully case-sensitive manner. -contains :: TaggedSentence -> Text -> Bool -contains ts tok = tok `elem` map fst ts - --- | True if the input sentence contains the given POS tag. --- Does not do partial matching (such as prefix matching) -containsTag :: TaggedSentence -> Tag -> Bool -containsTag ts tag = tag `elem` map snd ts +import GHC.Generics --- | Boolean type to indicate case sensitivity for textual --- comparisons. -data CaseSensitive = Sensitive | Insensitive - deriving (Read, Show, Generic) +import NLP.Types.General +import NLP.Types.Tags +import NLP.Types.Tree +-- data Tag t => TaggedSentence t = TS [(Text, t)] +-- deriving (Eq, Ord, Read, Show) -- | Part of Speech tagger, with back-off tagger. -- @@ -72,10 +60,10 @@ -- etc.) Look at the source for `NLP.POS.taggerTable` and -- `NLP.POS.UnambiguousTagger.readTagger` for examples. -- -data POSTagger = POSTagger - { posTagger :: [Sentence] -> [TaggedSentence] -- ^ The initial part-of-speech tagger. - , posTrainer :: [TaggedSentence] -> IO POSTagger -- ^ Training function to train the immediate POS tagger. - , posBackoff :: Maybe POSTagger -- ^ A tagger to invoke on unknown tokens. +data POSTagger t = POSTagger + { posTagger :: [Sentence] -> [TaggedSentence t] -- ^ The initial part-of-speech tagger. + , posTrainer :: [TaggedSentence t] -> IO (POSTagger t) -- ^ Training function to train the immediate POS tagger. + , posBackoff :: Maybe (POSTagger t) -- ^ A tagger to invoke on unknown tokens. , posTokenizer :: Text -> Sentence -- ^ A tokenizer; (`Data.Text.words` will work.) , posSplitter :: Text -> [Text] -- ^ A sentence splitter. If your input is formatted as -- one sentence per line, then use `Data.Text.lines`, @@ -87,29 +75,6 @@ -- algorithm used for this POS Tagger. This -- is used in deserialization } - --- | Remove the tags from a tagged sentence -stripTags :: TaggedSentence -> Sentence -stripTags = map fst - -newtype Tag = Tag Text - deriving (Ord, Eq, Read, Show, Generic) - -instance Serialize Tag - -fromTag :: Tag -> Text -fromTag (Tag t) = t - -parseTag :: Text -> Tag -parseTag t = Tag t - --- | Constant tag for "unknown" -tagUNK :: Tag -tagUNK = Tag "Unk" - -instance Serialize Text where - put txt = put $ encodeUtf8 txt - get = fmap decodeUtf8 get -- | Document corpus. -- diff --git a/src/NLP/Types/General.hs b/src/NLP/Types/General.hs new file mode 100644 --- /dev/null +++ b/src/NLP/Types/General.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +module NLP.Types.General +where + +import Data.Serialize (Serialize, put, get) +import Data.Text (Text) +import GHC.Generics + + +-- | Just a handy alias for Text +type Error = Text + +-- | Boolean type to indicate case sensitivity for textual +-- comparisons. +data CaseSensitive = Sensitive | Insensitive + deriving (Read, Show, Generic) + +instance Serialize CaseSensitive diff --git a/src/NLP/Types/Tags.hs b/src/NLP/Types/Tags.hs new file mode 100644 --- /dev/null +++ b/src/NLP/Types/Tags.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module NLP.Types.Tags +where + +import Data.Serialize (Serialize, get, put) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8, decodeUtf8) +import GHC.Generics + +import Test.QuickCheck (Arbitrary(..), NonEmptyList(..)) +import Test.QuickCheck.Instances () + +class (Ord a, Eq a, Read a, Show a, Generic a, Serialize a) => ChunkTag a where + fromChunk :: a -> Text + +class (Ord a, Eq a, Read a, Show a, Generic a, Serialize a) => Tag a where + fromTag :: a -> Text + parseTag :: Text -> a + tagUNK :: a + tagTerm :: a -> Text + +newtype RawChunk = RawChunk Text + deriving (Ord, Eq, Read, Show, Generic) + +instance Serialize RawChunk + +instance ChunkTag RawChunk where + fromChunk (RawChunk ch) = ch + +newtype RawTag = RawTag Text + deriving (Ord, Eq, Read, Show, Generic) + +instance Serialize RawTag + +-- | Tag instance for unknown tagsets. +instance Tag RawTag where + fromTag (RawTag t) = t + + parseTag t = RawTag t + + -- | Constant tag for "unknown" + tagUNK = RawTag "Unk" + + tagTerm (RawTag t) = t + +instance Arbitrary RawTag where + arbitrary = do + NonEmpty str <- arbitrary + return $ RawTag $ T.pack str + +instance Serialize Text where + put txt = put $ encodeUtf8 txt + get = fmap decodeUtf8 get + diff --git a/src/NLP/Types/Tree.hs b/src/NLP/Types/Tree.hs new file mode 100644 --- /dev/null +++ b/src/NLP/Types/Tree.hs @@ -0,0 +1,206 @@ +{-# LANGUAGE OverloadedStrings #-} +module NLP.Types.Tree where + +import Prelude hiding (print) +import Control.Applicative ((<$>), (<*>)) +import Data.String (IsString(..)) +import Data.Text (Text) +import qualified Data.Text as T +import Data.List (intercalate) + +import Test.QuickCheck (Arbitrary(..), listOf, elements, NonEmptyList(..)) +import Test.QuickCheck.Instances () + +import NLP.Types.Tags +import NLP.Types.General +import qualified NLP.Corpora.Brown as B + +-- | A sentence of tokens without tags. Generated by the tokenizer. +-- (tokenizer :: Text -> Sentence) +data Sentence = Sent [Token] + deriving (Read, Show, Eq) + +instance Arbitrary Sentence where + arbitrary = Sent <$> arbitrary + +tokens :: Sentence -> [Token] +tokens (Sent ts) = ts + +applyTags :: Tag t => Sentence -> [t] -> TaggedSentence t +applyTags (Sent ts) tags = TaggedSent $ zipWith POS tags ts + +-- | A chunked sentence has POS tags and chunk tags. Generated by a +-- chunker. +-- +-- (chunker :: (Chunk chunk, Tag tag) => TaggedSentence tag -> ChunkedSentence chunk tag) +data ChunkedSentence chunk tag = ChunkedSent [ChunkOr chunk tag] + deriving (Read, Show, Eq) + +instance (ChunkTag c, Arbitrary c, Arbitrary t, Tag t) => Arbitrary (ChunkedSentence c t) where + arbitrary = ChunkedSent <$> arbitrary + +-- | A tagged sentence has POS Tags. Generated by a part-of-speech +-- tagger. (tagger :: Tag tag => Sentence -> TaggedSentence tag) +data TaggedSentence tag = TaggedSent [POS tag] + deriving (Read, Show, Eq) + +instance (Arbitrary t, Tag t) => Arbitrary (TaggedSentence t) where + arbitrary = TaggedSent <$> arbitrary + +-- | Generate a Text representation of a TaggedSentence in the common +-- tagged format, eg: +-- +-- > "the/at dog/nn jumped/vbd ./." +-- +printTS :: Tag t => TaggedSentence t -> Text +printTS (TaggedSent ts) = T.intercalate " " $ map printPOS ts + +-- | Remove the tags from a tagged sentence +stripTags :: Tag t => TaggedSentence t -> Sentence +stripTags ts = fst $ unzipTags ts + +-- | Extract the tags from a tagged sentence, returning a parallel +-- list of tags along with the underlying Sentence. +unzipTags :: Tag t => TaggedSentence t -> (Sentence, [t]) +unzipTags (TaggedSent ts) = + let (tags, toks) = unzip $ map topair ts + topair (POS tag tok) = (tag, tok) + in (Sent toks, tags) + +-- | Combine the results of POS taggers, using the second param to +-- fill in 'tagUNK' entries, where possible. +combine :: Tag t => [TaggedSentence t] -> [TaggedSentence t] -> [TaggedSentence t] +combine xs ys = zipWith combineSentences xs ys + +combineSentences :: Tag t => TaggedSentence t -> TaggedSentence t -> TaggedSentence t +combineSentences (TaggedSent xs) (TaggedSent ys) = TaggedSent $ zipWith pickTag xs ys + +-- | Returns the first param, unless it is tagged 'tagUNK'. +-- Throws an error if the text does not match. +pickTag :: Tag t => POS t -> POS t -> POS t +pickTag a@(POS t1 txt1) b@(POS t2 txt2) + | txt1 /= txt2 = error ("Text does not match: "++ show a ++ " " ++ show b) + | t1 /= tagUNK = POS t1 txt1 + | otherwise = POS t2 txt1 + +-- | This type seem redundant, it just exists to support the +-- differences in TaggedSentence and ChunkedSentence. +-- +-- See the t3 example below to see how verbose this becomes. +data ChunkOr chunk tag = Chunk_CN (Chunk chunk tag) + | POS_CN (POS tag) + deriving (Read, Show, Eq) + +instance (ChunkTag c, Arbitrary c, Arbitrary t, Tag t) => Arbitrary (ChunkOr c t) where + arbitrary = elements =<< do + chunk <- mkChunk <$> arbitrary <*> listOf arbitrary + chink <- mkChink <$> arbitrary <*> arbitrary + return [chunk, chink] + +mkChunk :: (ChunkTag chunk, Tag tag) => chunk -> [ChunkOr chunk tag] -> ChunkOr chunk tag +mkChunk chunk children = Chunk_CN (Chunk chunk children) + +mkChink :: (ChunkTag chunk, Tag tag) => tag -> Token -> ChunkOr chunk tag +mkChink tag token = POS_CN (POS tag token) + + +data Chunk chunk tag = Chunk chunk [ChunkOr chunk tag] + deriving (Read, Show, Eq) + +instance (ChunkTag c, Arbitrary c, Arbitrary t, Tag t) => Arbitrary (Chunk c t) where + arbitrary = Chunk <$> arbitrary <*> arbitrary + +data POS tag = POS tag Token + deriving (Read, Show, Eq) + +instance (Arbitrary t, Tag t) => Arbitrary (POS t) where + arbitrary = POS <$> arbitrary <*> arbitrary + +-- | Show the underlying text token only. +showPOS :: Tag tag => POS tag -> Text +showPOS (POS _ (Token txt)) = txt + +-- | Show the text and tag. +printPOS :: Tag tag => POS tag -> Text +printPOS (POS tag (Token txt)) = T.intercalate "" [txt, "/", tagTerm tag] + +data Token = Token Text + deriving (Read, Show, Eq) + +instance Arbitrary Token where + arbitrary = do NonEmpty txt <- arbitrary + return $ Token (T.pack txt) + +instance IsString Token where + fromString = Token . T.pack + +showTok :: Token -> Text +showTok (Token txt) = txt + +suffix :: Token -> Text +suffix (Token str) | T.length str <= 3 = str + | otherwise = T.drop (T.length str - 3) str + +unTS :: Tag t => TaggedSentence t -> [POS t] +unTS (TaggedSent ts) = ts + +tsLength :: Tag t => TaggedSentence t -> Int +tsLength (TaggedSent ts) = length ts + +tsConcat :: Tag t => [TaggedSentence t] -> TaggedSentence t +tsConcat tss = TaggedSent (concatMap unTS tss) + +-- flattenText :: Tag t => TaggedSentence t -> Text +-- flattenText (TS ts) = T.unwords $ map fst ts + +-- | True if the input sentence contains the given text token. Does +-- not do partial or approximate matching, and compares details in a +-- fully case-sensitive manner. +contains :: Tag t => TaggedSentence t -> Text -> Bool +contains (TaggedSent ts) tok = any (posTokMatches tok) ts + +-- | True if the input sentence contains the given POS tag. +-- Does not do partial matching (such as prefix matching) +containsTag :: Tag t => TaggedSentence t -> t -> Bool +containsTag (TaggedSent ts) tag = any (posTagMatches tag) ts + +-- | Compare the POS-tag token with a supplied tag string. +posTagMatches :: Tag t => t -> POS t -> Bool +posTagMatches t1 (POS t2 _) = t1 == t2 + +-- | Compare the POS-tagged token with a text string. +posTokMatches :: Tag t => Text -> POS t -> Bool +posTokMatches txt (POS _ tok) = tokenMatches txt tok + +-- | Compare a token with a text string. +tokenMatches :: Text -> Token -> Bool +tokenMatches txt (Token tok) = txt == tok + + + +-- (S (NP (NN I)) (VP (V saw) (NP (NN him)))) +t1 :: Sentence +t1 = Sent + [ Token "I" + , Token "saw" + , Token "him" + , Token "." + ] + +t2 :: TaggedSentence B.Tag +t2 = TaggedSent + [ POS B.NN (Token "I") + , POS B.VB (Token "saw") + , POS B.NN (Token "him") + , POS B.Term (Token ".") + ] + +t3 :: ChunkedSentence B.Chunk B.Tag +t3 = ChunkedSent + [ mkChunk B.C_NP [ mkChink B.NN (Token "I") ] + , mkChunk B.C_VP [ mkChink B.VB (Token "saw") + , mkChink B.NN (Token "him") + ] + , mkChink B.Term (Token ".") + ] + diff --git a/tests/src/BackoffTaggerTests.hs b/tests/src/BackoffTaggerTests.hs --- a/tests/src/BackoffTaggerTests.hs +++ b/tests/src/BackoffTaggerTests.hs @@ -19,15 +19,15 @@ [ testCase "Simple back-off tagging" testLiteralBackoff ] -tagCat :: Map Text Tag -tagCat = Map.fromList [("cat", Tag "CAT")] +tagCat :: Map Text RawTag +tagCat = Map.fromList [("cat", RawTag "CAT")] -tagAnimals :: Map Text Tag -tagAnimals = Map.fromList [("cat", Tag "NN"), ("dog", Tag "NN")] +tagAnimals :: Map Text RawTag +tagAnimals = Map.fromList [("cat", RawTag "NN"), ("dog", RawTag "NN")] testLiteralBackoff :: Assertion testLiteralBackoff = let tgr = LT.mkTagger tagCat LT.Sensitive (Just $ LT.mkTagger tagAnimals LT.Sensitive Nothing) actual = tag tgr "cat dog" - oracle = [[("cat", Tag "CAT"), ("dog", Tag "NN")]] + oracle = [TaggedSent [(POS (RawTag "CAT") "cat"), (POS (RawTag "NN") "dog")]] in oracle @=? actual diff --git a/tests/src/IntegrationTests.hs b/tests/src/IntegrationTests.hs --- a/tests/src/IntegrationTests.hs +++ b/tests/src/IntegrationTests.hs @@ -29,15 +29,17 @@ import qualified NLP.POS.LiteralTagger as LT import qualified NLP.POS.UnambiguousTagger as UT +import qualified NLP.Corpora.Brown as B + import TestUtils tests :: Test tests = buildTest $ do - tagger <- defaultTagger + tagger <- defaultTagger :: IO (POSTagger B.Tag) return $ testGroup "Integration Tests" [ testGroup "Default Tagger" $ map (genTest $ tagText tagger) - [ ("Simple 1", "The dog jumped.", "The/at dog/nn jumped/vbd ./.") + [ ("Simple 1", "The dog jumped.", "The/AT dog/NN jumped/VBD ./.") ] , testGroup "POS Serialization" $ map (testSerialization examples) @@ -59,7 +61,7 @@ testSerialization :: [Text] -- ^ A training corpus. One sentence per entry. -> ( String -- ^ The name of the POS tagger. - , POSTagger) -- ^ An empty (untrained) POS tagger. + , POSTagger B.Tag) -- ^ An empty (untrained) POS tagger. -> Test testSerialization training (name, newTagger) = testCase name doTest where @@ -67,7 +69,8 @@ doTest = do preTagger <- train newTagger $ map readPOS training - let ePostTagger = deserialize taggerTable (serialize preTagger) + let ePostTagger :: Either String (POSTagger B.Tag) + ePostTagger = deserialize taggerTable (serialize preTagger) case ePostTagger of Left err -> assertFailure ("Tagger did not deserialize: "++err) Right postTagger -> do diff --git a/tests/src/Main.hs b/tests/src/Main.hs --- a/tests/src/Main.hs +++ b/tests/src/Main.hs @@ -13,21 +13,22 @@ import Test.Framework ( buildTest, testGroup, Test, defaultMain ) -- import Test.Framework.Skip (skip) -import NLP.Types (Tag(..), parseTag) +import NLP.Types (Tag(..), parseTag, RawTag(..), POSTagger(..)) import NLP.POS (tagText, train) import NLP.Corpora.Parsing (readPOS) -import qualified NLP.POS.AvgPerceptronTagger as APT import qualified AvgPerceptronTests as APT import qualified BackoffTaggerTests as Backoff -import qualified NLP.Similarity.VectorSimTests as Vec -import qualified NLP.POSTests as POS +import qualified Data.DefaultMapTests as DefMap +import qualified IntegrationTests as IT +import qualified NLP.Corpora.BrownTests as Brown +import qualified NLP.Extraction.ParsecTests as Parsec +import qualified NLP.POS.AvgPerceptronTagger as APT import qualified NLP.POS.UnambiguousTaggerTests as UT import qualified NLP.POS.LiteralTaggerTests as LT +import qualified NLP.POSTests as POS +import qualified NLP.Similarity.VectorSimTests as Vec import qualified NLP.TypesTests as TypeTests -import qualified Data.DefaultMapTests as DefMap -import qualified NLP.Extraction.ParsecTests as Parsec -import qualified IntegrationTests as IT import Corpora @@ -67,6 +68,7 @@ , DefMap.tests , Parsec.tests , IT.tests + , Brown.tests ] @@ -77,24 +79,33 @@ trainAndTagTestIO :: IO Text -> (Text, Text) -> Test trainAndTagTestIO corpora (input, oracle) = testCase (T.unpack input) $ do - tagger <- APT.trainNew =<< corpora - oracle @=? tagText (APT.mkTagger tagger Nothing) input + let parser :: Text -> RawTag + parser = parseTag + perceptron <- APT.trainNew parser =<< corpora + let tagger :: POSTagger RawTag + tagger = (APT.mkTagger perceptron Nothing) + oracle @=? tagText tagger input trainAndTagTest :: Text -> (Text, Text) -> Test trainAndTagTest corpora (input, oracle) = testCase (T.unpack input) $ do - tagger <- APT.trainNew corpora - oracle @=? tagText (APT.mkTagger tagger Nothing) input + let parser :: Text -> RawTag + parser = parseTag + perceptron <- APT.trainNew parser corpora + let tagger :: POSTagger RawTag + tagger = (APT.mkTagger perceptron Nothing) + oracle @=? tagText tagger input trainAndTagTestVTrainer :: Text -> (Text, Text) -> Test trainAndTagTestVTrainer corpora (input, oracle) = testCase (T.unpack input) $ do - let newTagger = APT.mkTagger APT.emptyPerceptron Nothing + let newTagger :: POSTagger RawTag + newTagger = APT.mkTagger APT.emptyPerceptron Nothing examples = map readPOS $ T.lines corpora posTgr <- train newTagger examples oracle @=? tagText posTgr input prop_parseTag :: Text -> Bool -prop_parseTag txt = parseTag txt == Tag txt +prop_parseTag txt = parseTag txt == RawTag txt genTest :: (Show a, Show b, Eq b) => (a -> b) -> (String, a, b) -> Test genTest fn (descr, input, oracle) = diff --git a/tests/src/NLP/Extraction/ParsecTests.hs b/tests/src/NLP/Extraction/ParsecTests.hs --- a/tests/src/NLP/Extraction/ParsecTests.hs +++ b/tests/src/NLP/Extraction/ParsecTests.hs @@ -30,52 +30,41 @@ , testProperty "followedBy" prop_followedBy , testGroup "Noun Phrase extractor" $ map (genTest parseNounPhrase) - [ ("Just NN", [("Dog", Tag "NN")] - , Just ("Dog", Tag "n-phr")) - , ("DT NN", [("The", Tag "DT"), ("dog", Tag "NN")] - , Just ("The dog", Tag "n-phr")) - , ("NN NN", [("Sunday", Tag "NN"), ("night", Tag "NN")] - , Just ("Sunday night", Tag "n-phr")) - , ("JJ NN", [("beautiful", Tag "JJ"), ("game", Tag "NN")] - , Just ("beautiful game", Tag "n-phr")) - , ("None - VB", [("jump", Tag "VB")] + [ ("Just NN", TaggedSent [(POS (RawTag "NN") "Dog")] + , Just (POS (RawTag "n-phr") "Dog")) + , ("DT NN", TaggedSent [(POS (RawTag "DT") "The"), (POS (RawTag "NN") "dog")] + , Just (POS (RawTag "n-phr") "The dog")) + , ("NN NN", TaggedSent [(POS (RawTag "NN") "Sunday"), (POS (RawTag "NN") "night")] + , Just (POS (RawTag "n-phr") "Sunday night")) + , ("JJ NN", TaggedSent [(POS (RawTag "JJ") "beautiful"), (POS (RawTag "NN") "game")] + , Just (POS (RawTag "n-phr") "beautiful game")) + , ("None - VB", TaggedSent [(POS (RawTag "VB") "jump")] , Nothing) ] ] -instance Arbitrary Tag where - arbitrary = do - NonEmpty str <- arbitrary - return $ Tag $ T.pack str - -instance Arbitrary TaggedSentence where - arbitrary = listOf $ do - NonEmpty tok <- arbitrary - tag <- arbitrary - return (T.pack tok, tag) - -prop_posTok :: TaggedSentence -> Property -prop_posTok taggedSent = taggedSent /= [] ==> - let (firstTok, firstTag) = head taggedSent +prop_posTok :: TaggedSentence RawTag -> Property +prop_posTok taggedSent = taggedSent /= TaggedSent [] ==> + let (POS firstTag firstTok) = head (unTS taggedSent) Right actual = parse (posTok firstTag) "prop_posTag" taggedSent - in (firstTok, firstTag) == actual + in (POS firstTag firstTok) == actual -prop_anyToken :: TaggedSentence -> Property -prop_anyToken taggedSent = taggedSent /= [] ==> +prop_anyToken :: TaggedSentence RawTag -> Property +prop_anyToken taggedSent = taggedSent /= TaggedSent [] ==> let actual = parse anyToken "prop_anyToken" taggedSent in isRight actual -prop_followedBy :: TaggedSentence -> Property -prop_followedBy taggedSent = taggedSent /= [] +prop_followedBy :: TaggedSentence RawTag -> Property +prop_followedBy taggedSent = taggedSent /= TaggedSent [] && not (contains taggedSent ".") ==> - let (theToken, theTag) = (".", Tag ".") + let (theToken, theTag) = (".", RawTag ".") extractor = followedBy anyToken $ txtTok Insensitive theToken Right actual = parse extractor "prop_followedBy" - (taggedSent ++ [(theToken, theTag)]) - in (theToken, theTag) == actual + (tsConcat [taggedSent, TaggedSent [POS theTag theToken]]) + in (POS theTag theToken) == actual -parseNounPhrase :: TaggedSentence -> Maybe (Text, Tag) +parseNounPhrase :: TaggedSentence RawTag -> Maybe (POS RawTag) parseNounPhrase sent = case parse nounPhrase "parseNounPhrase Test" sent of Left _ -> Nothing diff --git a/tests/src/NLP/POS/UnambiguousTaggerTests.hs b/tests/src/NLP/POS/UnambiguousTaggerTests.hs --- a/tests/src/NLP/POS/UnambiguousTaggerTests.hs +++ b/tests/src/NLP/POS/UnambiguousTaggerTests.hs @@ -32,17 +32,17 @@ ] ] -emptyTagger :: POSTagger +emptyTagger :: POSTagger RawTag emptyTagger = UT.mkTagger Map.empty Nothing -trainedTagger :: POSTagger -trainedTagger = UT.mkTagger (Map.fromList [("the", Tag "dt"), ("dog", Tag "vb")]) Nothing +trainedTagger :: POSTagger RawTag +trainedTagger = UT.mkTagger (Map.fromList [("the", RawTag "dt"), ("dog", RawTag "vb")]) Nothing prop_emptyAlwaysUnk :: String -> Bool -prop_emptyAlwaysUnk input = all (\(_, y) -> y == tagUNK) (concat $ tag emptyTagger inputTxt) +prop_emptyAlwaysUnk input = all (\(POS y _) -> y == tagUNK) (concatMap unTS $ tag emptyTagger inputTxt) where inputTxt = T.pack input -trainAndTagTest :: POSTagger -> (Text, Text, Text) -> Test +trainAndTagTest :: Tag t => POSTagger t -> (Text, Text, Text) -> Test trainAndTagTest tgr (exs, input, oracle) = testCase (T.unpack (T.intercalate ": " [exs, input])) $ do trained <- trainText tgr exs oracle @=? tagText trained input diff --git a/tests/src/NLP/POSTests.hs b/tests/src/NLP/POSTests.hs --- a/tests/src/NLP/POSTests.hs +++ b/tests/src/NLP/POSTests.hs @@ -16,10 +16,10 @@ tests :: Test tests = testGroup "NLP.POS" [ testGroup "Evaluation" $ map (genTestF $ eval mamalTagger) - [ ("Half", [ [ ("the", Tag "DT"), ("cat", Tag "NN")] - , [ ("the", Tag "DT"), ("dog", Tag "NN")] ], 0.5) - , ("All ", [ [ ("dog", Tag "NN"), ("cat", Tag "NN")] ], 1.0) - , ("None", [ [ ("the", Tag "DT"), ("couch", Tag "NN")] ], 0) + [ ("Half", [ TaggedSent [ (POS (RawTag "DT") "the"), (POS (RawTag "NN") "cat")] + , TaggedSent [ (POS (RawTag "DT") "the"), (POS (RawTag "NN") "dog")] ], 0.5) + , ("All ", [ TaggedSent [ (POS (RawTag "NN") "dog"), (POS (RawTag "NN") "cat")] ], 1.0) + , ("None", [ TaggedSent [ (POS (RawTag "DT") "the"), (POS (RawTag "NN") "couch")] ], 0) ] , testGroup "Serialization" [ testProperty "1 LiteralTagger" (prop_taggersRoundTrip mamalTagger) @@ -27,14 +27,14 @@ ] ] -animalTagger :: POSTagger -animalTagger = LT.mkTagger (Map.fromList [("owl", Tag "NN"), ("flea", Tag "NN")]) LT.Sensitive (Just mamalTagger) +animalTagger :: POSTagger RawTag +animalTagger = LT.mkTagger (Map.fromList [("owl", RawTag "NN"), ("flea", RawTag "NN")]) LT.Sensitive (Just mamalTagger) -mamalTagger :: POSTagger -mamalTagger = LT.mkTagger (Map.fromList [("cat", Tag "NN"), ("dog", Tag "NN")]) LT.Sensitive Nothing +mamalTagger :: POSTagger RawTag +mamalTagger = LT.mkTagger (Map.fromList [("cat", RawTag "NN"), ("dog", RawTag "NN")]) LT.Sensitive Nothing -- TODO need to make random taggers to really test this... -prop_taggersRoundTrip :: POSTagger -> String -> Bool +prop_taggersRoundTrip :: POSTagger RawTag -> String -> Bool prop_taggersRoundTrip tgr input = - let Right roundTripped = deserialize taggerTable $ serialize tgr + let Right roundTripped = (deserialize taggerTable $ serialize tgr) :: Either String (POSTagger RawTag) in tagStr tgr ("cat owl " ++ input) == tagStr roundTripped ("cat owl " ++ input)