diff --git a/NLP/Miniutter/English.hs b/NLP/Miniutter/English.hs --- a/NLP/Miniutter/English.hs +++ b/NLP/Miniutter/English.hs @@ -6,17 +6,21 @@ ) where import Data.Binary -import Data.Char (isAlphaNum, toUpper) +import Data.Char (isAlphaNum, isSpace, toUpper) import Data.Map (Map) import qualified Data.Map as Map -import Data.Semigroup as Sem import Data.String (IsString (..)) import Data.Text (Text) import qualified Data.Text as T import GHC.Generics (Generic) import NLP.Minimorph.English -import NLP.Minimorph.Util hiding ((<>)) +import NLP.Minimorph.Util +#if !(MIN_VERSION_base(4,11,0)) + -- this is redundant starting with base-4.11 / GHC 8.4 +import Data.Semigroup +#endif + -- | Various basic and compound parts of English simple present tense clauses. -- Many of the possible nestings do not make sense. We don't care. data Part = @@ -32,9 +36,9 @@ -- ^ plural prefixed with a cardinal, spelled | CarAWs !Int !Part -- ^ plural prefixed with a cardinal, not spelled, -- with \"a\" for 1 and \"no\" for 0 - | CarWs !Int !Part -- ^ plural prefixed with a cardinal, not spelled; - | Car1Ws !Int !Part -- ^ plural prefixed with a cardinal, not spelled; - -- no prefix at all for 1 + | CarWs !Int !Part -- ^ plural prefixed with a cardinal, not spelled + | Car1Ws !Int !Part -- ^ plural prefixed with a cardinal, not spelled, + -- with no prefix at all for 1 | Ordinal !Int -- ^ ordinal number, spelled in full up to 10 | Ord !Int -- ^ ordinal number, not spelled | AW !Part -- ^ phrase with indefinite article @@ -65,7 +69,7 @@ instance IsString Part where fromString = Text . T.pack -instance Sem.Semigroup Part where +instance Semigroup Part where (<>) = Append instance Monoid Part where @@ -178,15 +182,23 @@ onLastWord :: (Text -> Text) -> Text -> Text onLastWord f t = - let (spanPrefix, spanRest) = T.span isWordLetter $ T.reverse t + -- First ignore (and append afterwards) a suffix composed not of possible + -- word letters and also of any trailing whitespace. We don't want + -- to pluralise whitespace nor symbols, but neither to lose them. + let (wordPrefix, nonWordSuffix) = + let (wordP, nonWordP) = T.span (\c -> isWordLetter c || isSpace c) t + (wordSpaceR, wordRestR) = T.span isSpace $ T.reverse wordP + in (T.reverse wordRestR, T.reverse wordSpaceR <> nonWordP) + (spanPrefix, spanRest) = T.span isWordLetter $ T.reverse wordPrefix (ending, restRaw) = (T.reverse spanPrefix, T.reverse spanRest) rest = T.dropWhile (not . isWordLetter) restRaw fending = f ending - in if T.null ending - then t - else if T.null fending - then rest - else restRaw <> f ending + onLast = if T.null ending + then wordPrefix + else if T.null fending + then rest + else restRaw <> f ending + in onLast <> nonWordSuffix onFirstWordPair :: (Text -> (Text, Text)) -> Text -> (Text, Text) onFirstWordPair f t = @@ -360,28 +372,22 @@ -- TODO: use a suffix tree, to catch ableman, seaman, etc.? -- | Default set of nouns with irregular plural form. defIrrPlural :: Map Text Text -defIrrPlural = Map.fromList +defIrrPlural = Map.fromList $ concatMap generateCapitalized $ [ ("bro", "bros") - , ("Bro", "Bros") , ("canto", "cantos") , ("homo", "homos") , ("photo", "photos") - , ("Photo", "Photos") , ("zero", "zeros") , ("piano", "pianos") - , ("Piano", "Pianos") , ("portico", "porticos") , ("pro", "pros") , ("quarto", "quartos") , ("kimono", "kimonos") , ("knife", "knives") - , ("Knife", "Knives") , ("life", "lives") - , ("Life", "Lives") , ("dwarf", "dwarfs") -- not for ME dwarves though , ("proof", "proofs") , ("roof", "roofs") - , ("Roof", "Roofs") , ("turf", "turfs") , ("child", "children") , ("foot", "feet") @@ -401,16 +407,19 @@ , ("trout", "trout") , ("swine", "swine") , ("aircraft", "aircraft") - , ("Aircraft", "Aircraft") , ("watercraft", "watercraft") , ("spacecraft", "spacecraft") - , ("Spacecraft", "Spacecraft") , ("hovercraft", "hovercraft") , ("information", "information") - , ("Information", "Information") , ("whiff", "whiffs") , ("graffiti", "graffiti") ] + +generateCapitalized :: (Text, Text) -> [(Text, Text)] +generateCapitalized (t1, t2) = + let t1C = capitalize t1 + t2C = capitalize t2 + in if t1 == t1C then [(t1, t2)] else [(t1, t2), (t1C, t2C)] -- | Default set of nouns with irregular indefinite article. defIrrIndefinite :: Map Text Text diff --git a/miniutter.cabal b/miniutter.cabal --- a/miniutter.cabal +++ b/miniutter.cabal @@ -5,7 +5,7 @@ -- PVP summary:+-+------- breaking API changes -- | | +----- minor or non-breaking API additions -- | | | +--- code changes with no API change -version: 0.5.0.0 +version: 0.5.1.0 synopsis: Simple English clause creation from arbitrary words description: This library helps in generating simple present tense English sentences from short, parametrized descriptions. @@ -20,7 +20,7 @@ bug-reports: https://github.com/Mikolaj/miniutter/issues license: BSD3 license-file: LICENSE -tested-with: GHC >= 7.4 && <= 8.6 +tested-with: GHC >= 7.8 && <= 8.6 data-files: LICENSE, README.md author: Mikolaj Konarski maintainer: Mikolaj Konarski @@ -34,7 +34,7 @@ library exposed-modules: NLP.Miniutter.English - build-depends: base >= 4 && < 5, + build-depends: base >= 4.7 && < 5, binary >= 0.6.3.0 && < 1, text >= 0.11.2.3 && < 2, containers >= 0.4.1 && < 1, @@ -48,10 +48,11 @@ default-extensions: MonoLocalBinds, ScopedTypeVariables, OverloadedStrings BangPatterns, RecordWildCards, NamedFieldPuns, MultiWayIf, LambdaCase, DefaultSignatures, InstanceSigs, - MonadFailDesugaring, StrictData, CPP - ghc-options: -Wall -Wcompat -Worphans -Wincomplete-uni-patterns -Wincomplete-record-updates -Wmissing-home-modules -Widentities -Wredundant-constraints + PatternSynonyms, StrictData, CPP + other-extensions: DeriveGeneric + ghc-options: -Wall -Wcompat -Worphans -Wincomplete-uni-patterns -Wincomplete-record-updates -Wmissing-home-modules -Widentities -Wredundant-constraints -Wpartial-fields ghc-options: -Wall-missed-specialisations - ghc-options: -fno-ignore-asserts -fexpose-all-unfoldings -fspecialise-aggressively + ghc-options: -fno-ignore-asserts -fexpose-all-unfoldings -fspecialise-aggressively -fsimpl-tick-factor=200 } else { default-extensions: CPP, OverloadedStrings, NamedFieldPuns } @@ -61,9 +62,9 @@ main-is: test-miniutter.hs hs-source-dirs: test build-depends: miniutter, - base >= 4 && < 5, - text >= 0.11.2.3 && < 2, - containers >= 0.4.1 && < 1, + base, + text, + containers, test-framework >= 0.6 && < 1, test-framework-hunit >= 0.2 && < 1, HUnit >= 1.2 && < 2 @@ -76,10 +77,11 @@ default-extensions: MonoLocalBinds, ScopedTypeVariables, OverloadedStrings BangPatterns, RecordWildCards, NamedFieldPuns, MultiWayIf, LambdaCase, DefaultSignatures, InstanceSigs, - MonadFailDesugaring, StrictData, CPP - ghc-options: -Wall -Wcompat -Worphans -Wincomplete-uni-patterns -Wincomplete-record-updates -Wmissing-home-modules -Widentities -Wredundant-constraints + PatternSynonyms, StrictData, CPP + ghc-options: -Wall -Wcompat -Worphans -Wincomplete-uni-patterns -Wincomplete-record-updates -Wmissing-home-modules -Widentities -Wredundant-constraints -Wpartial-fields ghc-options: -Wall-missed-specialisations - ghc-options: -fno-ignore-asserts -fexpose-all-unfoldings -fspecialise-aggressively + ghc-options: -fno-ignore-asserts -fexpose-all-unfoldings -fspecialise-aggressively -fsimpl-tick-factor=200 + ghc-options: -threaded -rtsopts } else { default-extensions: CPP, OverloadedStrings, NamedFieldPuns } diff --git a/test/test-miniutter.hs b/test/test-miniutter.hs --- a/test/test-miniutter.hs +++ b/test/test-miniutter.hs @@ -1,12 +1,16 @@ module Main where -import Data.Monoid import qualified Data.Text as T import Test.Framework (Test, defaultMain, testGroup) import Test.Framework.Providers.HUnit (testCase) import Test.HUnit (assertEqual) +#if !(MIN_VERSION_base(4,11,0)) + -- this is redundant starting with base-4.11 / GHC 8.4 +import Data.Semigroup +#endif + import qualified NLP.Miniutter.English as MU main :: IO () @@ -80,9 +84,9 @@ [ tp [MU.Ws "dog"] "dogs" , tp [MU.Ws "dogs"] "dogses" , tp [MU.Ws "blue dog"] "blue dogs" - , tp [MU.Ws "blue dog "] "blue dog " - , tp [MU.Ws "blue dog."] "blue dog." - , tp [MU.Ws "blue dog%"] "blue dog%" + , tp [MU.Ws "blue dog "] "blue dogs " + , tp [MU.Ws "blue dog."] "blue dogs." + , tp [MU.Ws "blue dog%"] "blue dogs%" , tp [MU.Ws "bitch"] "bitches" , tp [MU.Ws "the fish"] "the fishes" , tp [MU.Ws "miss"] "misses" @@ -109,14 +113,14 @@ , tp [MU.Ws "dwarf"] "dwarfs" , tp [MU.Ws "hoof"] "hooves" , tp [MU.Ws "elf"] "elves" ---, tp [MU.Ws "staff"] "staves" -- depends on the meaning :( + , tp [MU.Ws "staff"] "staves" -- though depends on the meaning :( , tp [MU.Ws "child"] "children" , tp [MU.Ws "foot"] "feet" , tp [MU.Ws "goose"] "geese" , tp [MU.Ws "louse"] "lice" , tp [MU.Ws "man"] "men" , tp [MU.Ws "mouse"] "mice" - , tp [MU.Ws "tooth"] "teeth" + , tp [MU.Ws "Tooth"] "Teeth" , tp [MU.Ws "woman"] "women" , tp [MU.Ws "buffalo"] "buffalo" , tp [MU.Ws "deer"] "deer" @@ -125,11 +129,11 @@ , tp [MU.Ws "bison"] "bison" , tp [MU.Ws "salmon"] "salmon" , tp [MU.Ws "pike"] "pike" - , tp [MU.Ws "trout"] "trout" + , tp [MU.Ws "Trout"] "Trout" , tp [MU.Ws "swine"] "swine" , tp [MU.Ws "aircraft"] "aircraft" , tp [MU.Ws "watercraft"] "watercraft" - , tp [MU.Ws "spacecraft"] "spacecraft" + , tp [MU.Ws "Spacecraft"] "Spacecraft" , tp [MU.Ws "hovercraft"] "hovercraft" , tp [MU.Ws "information"] "information" , tp [MU.Ws (MU.String "dog blue")] "dog blues" @@ -139,9 +143,9 @@ , tp [MU.Ws (MU.Ord 1)] "1sts" , tp [MU.Ws (MU.AW "elf")] "an elves" , tp [MU.Ws (MU.WWandW ["dog", "eagle", "parrot"])] - "dog, eagle and parrots" + "dogs, eagle and parrot" , tp [MU.Ws (MU.WWxW "and also" ["dog", "eagle", "parrot"])] - "dog, eagle and also parrots" + "dogs, eagle and also parrot" , tp [MU.Ws (MU.Wown "uncle")] "uncle'ses" , tp [MU.Ws (MU.WownW "uncle" "dog")] "uncle's dogs" , tp [MU.Ws (MU.Phrase ["uncle", "dog"])] "uncle dogs" @@ -170,7 +174,7 @@ , tp [MU.Car1Ws 1 "blue dog"] "blue dog" , tp [MU.CarWs 1 "blue dog"] "1 blue dog" , tp [MU.Car1Ws 2 "blue elf"] "2 blue elves" - , tp [MU.CardinalWs 2 " dog "] "two dog " + , tp [MU.CardinalWs 2 " dog "] "two dogs " , tp [MU.CarAWs 3 "leaf"] "3 leaves" , tp [MU.CardinalAWs 0 "sheep"] "no sheep" , tp [MU.CardinalAWs 1 "sheep"] "a sheep" @@ -252,7 +256,7 @@ testMakePhrasePossesive :: Test testMakePhrasePossesive = testGroup "the possesive form" [ tp [MU.Wown (MU.String "uncle")] "uncle's" - , tp [MU.Wown (MU.String " uncle ")] " uncle " + , tp [MU.Wown (MU.String " uncle ")] " uncle's " , tp [MU.Wown ""] "" , tp [MU.Wown " "] " " , tp [MU.Wown "miss"] "miss'" @@ -268,7 +272,7 @@ , tp [MU.Wown "We"] "Ours" , tp [MU.Wown "they"] "theirs" , tp [MU.WownW (MU.String "uncle") (MU.String "dog")] "uncle's dog" - , tp [MU.WownW " uncle " "dog"] " uncle dog" + , tp [MU.WownW " uncle " "dog"] " uncle's dog" , tp [MU.WownW "I" ""] "my" , tp [MU.WownW "" "dog"] "dog" , tp [MU.WownW "" ""] "" @@ -295,7 +299,7 @@ , tp [MU.Wown $ MU.Wown $ MU.Wown $ MU.Wown "it"] "its's'" , tp [MU.Wown (MU.SubjectVerb MU.Sg3rd MU.Why "I" "be")] "am mine" , tp [MU.Wown " do I"] " do mine" - , tp [MU.Wown " do I "] " do I " + , tp [MU.Wown " do I "] " do mine " ] testMakePhraseSubjectVerb :: Test