diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,30 +1,27 @@ -Copyright (c) 2015-2017, Mikolaj Konarski +BSD 3-Clause License +Copyright (c) 2015-2019, Mikolaj Konarski All rights reserved. Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Mikolaj Konarski nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. +3. Neither the name of the copyright holder nor the names of its + contributors may be used to endorse or promote products derived from + this software without specific prior written permission. -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/NLP/Miniutter/English.hs b/NLP/Miniutter/English.hs --- a/NLP/Miniutter/English.hs +++ b/NLP/Miniutter/English.hs @@ -1,7 +1,7 @@ -{-# LANGUAGE DeriveGeneric, OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} -- | Simple English clause creation parameterized by individual words. module NLP.Miniutter.English - ( Part(..), Person(..), Polarity(..), Irregular + ( Part(..), Person(..), Polarity(..), Irregular(..) , makeSentence, makePhrase, defIrregular, (<+>) ) where @@ -20,12 +20,21 @@ -- | 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 = - String !String -- ^ handle for a String parameter - | Text !Text -- ^ handle for a Text parameter + String !String -- ^ handle for a @String@ parameter + | Text !Text -- ^ handle for a @Text@ parameter | Cardinal !Int -- ^ cardinal number, spelled in full up to 10 + | Car !Int -- ^ cardinal number, not spelled | Ws !Part -- ^ plural form of a phrase - | CarWs !Int !Part -- ^ plural prefixed with a cardinal, not spelled - | CardinalWs !Int !Part -- ^ plural prefixed with a cardinal, spelled + | CardinalAWs !Int !Part + -- ^ plural prefixed with a cardinal, spelled, + -- with \"a\" for 1 and \"no\" for 0 + | CardinalWs !Int !Part + -- ^ 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 | Ordinal !Int -- ^ ordinal number, spelled in full up to 10 | Ord !Int -- ^ ordinal number, not spelled | AW !Part -- ^ phrase with indefinite article @@ -33,20 +42,19 @@ | WWxW !Part ![Part] -- ^ collection | Wown !Part -- ^ non-premodifying possesive | WownW !Part !Part -- ^ attributive possesive - | Append !Part !Part -- ^ no space in between - | !Part :> !Part -- ^ no space in between -- deprecated, use <> + | Append !Part !Part -- ^ no space in between; one can also just use @<>@ | Phrase ![Part] -- ^ space-separated sequence | Capitalize !Part -- ^ make the first letter into a capital letter | SubjectVerb !Person !Polarity !Part !Part -- ^ conjugation according to polarity, - -- with a default person (pronouns override it) + -- with a default person (pronouns override it) | SubjectVerbSg !Part !Part - -- ^ a shorthand for Sg3rd and Yes + -- ^ a shorthand for @Sg3rd@ and @Yes@ | SubjectVVxV !Part !Person !Polarity !Part ![Part] -- ^ conjugation of all verbs according to polarity, - -- with a default person (pronouns override it) + -- with a default person (pronouns override it) | SubjectVVandVSg !Part ![Part] - -- ^ a shorthand for "and", Sg3rd and Yes + -- ^ a shorthand for \"and\", @Sg3rd@ and @Yes@ deriving (Show, Eq, Ord, Generic) instance Binary Part @@ -82,11 +90,15 @@ -- | Nouns with irregular plural form and nouns with irregular indefinite -- article. -type Irregular = (Map Text Text, Map Text Text) +data Irregular = Irregular + { irrPlural :: Map Text Text + , irrIndefinite :: Map Text Text + } -- | Default set of words with irregular forms. defIrregular :: Irregular -defIrregular = (defIrrPlural, defIrrIndefinite) +defIrregular = + Irregular {irrPlural = defIrrPlural, irrIndefinite = defIrrIndefinite} -- | Realise a complete sentence, capitalized, ending with a dot. makeSentence :: Irregular -> [Part] -> Text @@ -106,11 +118,20 @@ String t -> T.pack t Text t -> t Cardinal n -> cardinal n + Car n -> tshow n Ws p -> onLastWord (makePlural irr) (mkPart p) - CarWs 1 p -> mkPart (AW p) -- TOOD: a variant without 'a' - CarWs n p -> T.pack (show n) <+> onLastWord (makePlural irr) (mkPart p) - CardinalWs 1 p -> mkPart (AW p) + CardinalAWs 0 p -> "no" <+> onLastWord (makePlural irr) (mkPart p) + CardinalAWs 1 p -> mkPart (AW p) + CardinalAWs n p -> cardinal n <+> onLastWord (makePlural irr) (mkPart p) + CardinalWs 1 p -> cardinal 1 <+> mkPart p -- spelled number CardinalWs n p -> cardinal n <+> onLastWord (makePlural irr) (mkPart p) + CarAWs 0 p -> "no" <+> onLastWord (makePlural irr) (mkPart p) + CarAWs 1 p -> mkPart (AW p) + CarAWs n p -> tshow n <+> onLastWord (makePlural irr) (mkPart p) + CarWs 1 p -> "1" <+> mkPart p + CarWs n p -> tshow n <+> onLastWord (makePlural irr) (mkPart p) + Car1Ws 1 p -> mkPart p -- no number, article, anything; useful + Car1Ws n p -> tshow n <+> onLastWord (makePlural irr) (mkPart p) Ordinal n -> ordinal n Ord n -> ordinalNotSpelled n AW p -> onFirstWord (addIndefinite irr) (mkPart p) @@ -124,7 +145,6 @@ WownW p1 p2 -> onLastWord attributive (mkPart p1) <+> mkPart p2 Phrase lp -> makePhrase irr lp Append p1 p2 -> mkPart p1 <> mkPart p2 - p1 :> p2 -> mkPart p1 <> mkPart p2 Capitalize p -> capitalize $ mkPart p SubjectVerb defaultPerson Yes s v -> subjectVerb defaultPerson (mkPart s) (mkPart v) @@ -188,13 +208,13 @@ Just (c, rest) -> T.cons (toUpper c) rest makePlural :: Irregular -> Text -> Text -makePlural (irrPlural, _) t = +makePlural Irregular{irrPlural} t = case Map.lookup t irrPlural of Just u -> u Nothing -> defaultNounPlural t addIndefinite :: Irregular -> Text -> Text -addIndefinite (_, irrIndefinite) t = +addIndefinite Irregular{irrIndefinite} t = case Map.lookup t irrIndefinite of Just u -> u <+> t Nothing -> indefiniteDet t <+> t @@ -388,6 +408,8 @@ , ("hovercraft", "hovercraft") , ("information", "information") , ("Information", "Information") + , ("whiff", "whiffs") + , ("graffiti", "graffiti") ] -- | Default set of nouns with irregular indefinite article. diff --git a/miniutter.cabal b/miniutter.cabal --- a/miniutter.cabal +++ b/miniutter.cabal @@ -2,10 +2,10 @@ -- The package version. See the Haskell package versioning policy (PVP) -- for standards guiding when and how versions should be incremented. -- http://www.haskell.org/haskellwiki/Package_versioning_policy --- PVP summary: +-+------- breaking API changes --- | | +----- non-breaking API additions --- | | | +--- code changes with no API change -version: 0.4.7.0 +-- PVP summary:+-+------- breaking API changes +-- | | +----- minor or non-breaking API additions +-- | | | +--- code changes with no API change +version: 0.5.0.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,8 +20,8 @@ bug-reports: https://github.com/Mikolaj/miniutter/issues license: BSD3 license-file: LICENSE -tested-with: GHC >= 7.4.2 && <= 8.4 -extra-source-files: LICENSE, README.md +tested-with: GHC >= 7.4 && <= 8.6 +data-files: LICENSE, README.md author: Mikolaj Konarski maintainer: Mikolaj Konarski category: Natural Language Processing @@ -34,24 +34,27 @@ library exposed-modules: NLP.Miniutter.English --- other-modules: build-depends: base >= 4 && < 5, binary >= 0.6.3.0 && < 1, - ghc-prim >= 0.2, text >= 0.11.2.3 && < 2, containers >= 0.4.1 && < 1, - minimorph >= 0.1.6 && < 1 + minimorph >= 0.2.0.0 && < 1 if !impl(ghc >= 8.0) build-depends: semigroups == 0.18.* default-language: Haskell2010 - default-extensions: MonoLocalBinds, ScopedTypeVariables, - BangPatterns, RecordWildCards, NamedFieldPuns, CPP - other-extensions: OverloadedStrings ---, DeriveGeneric - ghc-options: -Wall -fwarn-orphans -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -fwarn-monomorphism-restriction -fwarn-unrecognised-pragmas - ghc-options: -fno-warn-implicit-prelude - ghc-options: -fno-ignore-asserts -funbox-strict-fields + if impl(ghc >= 8.0) + { + 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 + ghc-options: -Wall-missed-specialisations + ghc-options: -fno-ignore-asserts -fexpose-all-unfoldings -fspecialise-aggressively + } else { + default-extensions: CPP, OverloadedStrings, NamedFieldPuns + } test-suite test-miniutter type: exitcode-stdio-1.0 @@ -68,9 +71,15 @@ build-depends: semigroups == 0.18.* default-language: Haskell2010 - default-extensions: MonoLocalBinds, ScopedTypeVariables, - BangPatterns, RecordWildCards, NamedFieldPuns, CPP - other-extensions: OverloadedStrings - ghc-options: -Wall -fwarn-orphans -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -fwarn-monomorphism-restriction -fwarn-unrecognised-pragmas - ghc-options: -fno-warn-implicit-prelude - ghc-options: -fno-ignore-asserts -funbox-strict-fields + if impl(ghc >= 8.0) + { + 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 + ghc-options: -Wall-missed-specialisations + ghc-options: -fno-ignore-asserts -fexpose-all-unfoldings -fspecialise-aggressively + } 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,7 +1,6 @@ -{-# LANGUAGE OverloadedStrings #-} module Main where -import Data.Monoid +import Data.Monoid import qualified Data.Text as T import Test.Framework (Test, defaultMain, testGroup) @@ -60,8 +59,9 @@ , tp [MU.Phrase ["blue", ""]] "blue" , tp [MU.Phrase ["", "dog"]] "dog" , tp [MU.Phrase ["", ""]] "" - , tp [MU.Ordinal 0 <> ", but", MU.Ordinal 1] "0th, but first" - , tp [MU.Cardinal 20 <> MU.Cardinal 0] "200" + , tp [MU.Ordinal 0 <> ", but", MU.Ordinal 1] "zeroth, but first" + , tp [MU.Cardinal 20 <> MU.Cardinal 0] "20zero" + , tp [MU.Cardinal 20 <> MU.Car 0] "200" , tp [MU.String " "] " " , tp [ " "] " " , tp [MU.String " blue ", MU.String " dog "] " blue dog " @@ -135,7 +135,7 @@ , tp [MU.Ws (MU.String "dog blue")] "dog blues" , tp [MU.Ws (MU.Ordinal 1)] "firsts" , tp [MU.Ws (MU.Ws "do")] "doeses" - , tp [MU.Ws (MU.CarWs 1 "man")] "a men" + , tp [MU.Ws (MU.CarAWs 1 "man")] "a men" , tp [MU.Ws (MU.Ord 1)] "1sts" , tp [MU.Ws (MU.AW "elf")] "an elves" , tp [MU.Ws (MU.WWandW ["dog", "eagle", "parrot"])] @@ -164,15 +164,23 @@ , tp [MU.Ordinal 131, MU.Cardinal 2] "131st two" , tp [MU.Ordinal (-3)] "-3rd" , tp [MU.Ordinal 9999992] "9999992nd" - , tp [MU.CarWs 1 "blue dog"] "a blue dog" - , tp [MU.CarWs 2 "blue elf"] "2 blue elves" + , tp [MU.CarAWs 0 "blue dog"] "no blue dogs" + , tp [MU.CarAWs 1 "blue dog"] "a blue dog" + , tp [MU.Car1Ws 0 "blue dog"] "0 blue dogs" + , 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.CarWs 3 "leaf"] "3 leaves" - , tp [MU.CardinalWs 4 "sheep"] "four sheep" - , tp [MU.CarWs (-1) "dog"] "-1 dogs" - , tp [MU.CardinalWs (-3) "dog"] "-3 dogs" + , tp [MU.CarAWs 3 "leaf"] "3 leaves" + , tp [MU.CardinalAWs 0 "sheep"] "no sheep" + , tp [MU.CardinalAWs 1 "sheep"] "a sheep" + , tp [MU.CardinalAWs 4 "sheep"] "four sheep" + , tp [MU.Car1Ws (-1) "dog"] "-1 dogs" + , tp [MU.CardinalAWs (-3) "dog"] "-3 dogs" , tp [MU.CardinalWs 12 ""] "12" , tp [MU.CarWs 5 (MU.Cardinal 1)] "5 ones" + , tp [MU.CardinalWs 0 (MU.Ordinal 2)] "zero seconds" + , tp [MU.CardinalWs 1 (MU.Ordinal 2)] "one second" , tp [MU.CardinalWs 4 (MU.Ordinal 2)] "four seconds" , tp [MU.Ord 2] "2nd" , tp [MU.Ord 3] "3rd" @@ -189,8 +197,8 @@ , tp [MU.Ord 4 <> MU.Ordinal 2] "4thsecond" , tp [MU.Ord 4 <> MU.Ord 7] "4th7th" , tp [MU.Ord 4 <> MU.CarWs 7 "dog"] "4th7 dogs" - , tp [MU.CardinalWs 4 (MU.CarWs 7 "dog")] "four 7 dogses" - , tp [MU.CarWs 4 (MU.Ord 7 <> "elf")] "4 7thelves" + , tp [MU.CardinalWs 4 (MU.CarAWs 7 "dog")] "four 7 dogses" + , tp [MU.Car1Ws 4 (MU.Ord 7 <> "elf")] "4 7thelves" ] testMakePhraseIndefinite :: Test @@ -277,9 +285,9 @@ , tp [MU.WownW "It" "dog"] "Its dog" , tp [MU.WownW "we" "dog"] "our dog" , tp [MU.WownW "They" "dog"] "Their dog" - , tp [MU.Wown (MU.CarWs 6 "")] "6's" + , tp [MU.Wown (MU.Car1Ws 6 "")] "6's" , tp [MU.Wown (MU.Ord 1)] "1st's" - , tp [MU.Wown (MU.Ws (MU.CardinalWs 6 ""))] "sixes'" + , tp [MU.Wown (MU.Ws (MU.CardinalAWs 6 ""))] "sixes'" , tp [MU.Wown (MU.WWandW ["I", "you"])] "I and yours" , tp [MU.Wown (MU.WWandW ["you", "I"])] "you and mine" , tp [MU.WownW (MU.WWandW ["you", "I"]) "dog"] "you and my dog" @@ -418,7 +426,7 @@ , "you" ] "Haskell Alvin displaces you." , tc [ MU.SubjectVerbSg "Haskell Alvin" "drop" - , MU.CarWs 1 "royal blue vial" ] + , MU.CarAWs 1 "royal blue vial" ] "Haskell Alvin drops a royal blue vial." , tc [ MU.SubjectVerbSg "Haskell Alvin" "gulp down" , MU.AW "royal blue vial" ] @@ -426,13 +434,13 @@ , tc [ MU.SubjectVerbSg "Haskell Alvin" "feel better" ] "Haskell Alvin feels better." , tc [ MU.SubjectVerbSg "the royal blue vial" "turn out to be" - , MU.CarWs 1 "vial of healing (+5)" ] - "The royal blue vial turns out to be a vial of healing (+5)." + , MU.CardinalWs 1 "vial of healing (+5)" ] + "The royal blue vial turns out to be one vial of healing (+5)." , tc [ MU.SubjectVerbSg "you" "gulp down" , MU.AW "magenta vial" ] "You gulp down a magenta vial." , tc [ MU.SubjectVerbSg "the magenta vial" "turn out to be" - , MU.CarWs 1 "vial of rose water" ] + , MU.CarAWs 1 "vial of rose water" ] "The magenta vial turns out to be a vial of rose water." , tc [ MU.SubjectVerbSg "deranged household robot" "trie to hit" <> ", but you block" ] @@ -441,11 +449,11 @@ , "you" ] "Deranged household robot hits you." , tc [ MU.SubjectVerbSg "deranged household robot" "pick up" - , MU.CarWs 2 "sharpened pipe", "(3d1) (+1)" ] + , MU.Car1Ws 2 "sharpened pipe", "(3d1) (+1)" ] "Deranged household robot picks up 2 sharpened pipes (3d1) (+1)." , tc [ MU.SubjectVerbSg "deranged household robot" "hit" , MU.Text"you with", MU.CardinalWs 1 "sharpened pipe (3d1) (+1)" ] - "Deranged household robot hits you with a sharpened pipe (3d1) (+1)." + "Deranged household robot hits you with one sharpened pipe (3d1) (+1)." , tc [ MU.SubjectVerbSg "you" "kick" , "deranged household robot" ] "You kick deranged household robot." @@ -474,7 +482,7 @@ , tc [ MU.SubjectVerbSg "deformed monkey" "hit" , "deranged household robot" ] "Deformed monkey hits deranged household robot." - , tc [ MU.SubjectVerbSg (MU.CarWs 1 "flying billiard ball (1d1)") "hit" + , tc [ MU.SubjectVerbSg (MU.CarAWs 1 "flying billiard ball (1d1)") "hit" , "deranged household robot" ] "A flying billiard ball (1d1) hits deranged household robot." , tc [ MU.SubjectVerbSg "deranged household robot" "hiss in pain" ]