{-# LANGUAGE DeriveGeneric #-}
-- | Simple English clause creation parameterized by individual words.
-- See the tests for example texts generated.
module NLP.Miniutter.English
  ( Part(..), Person(..), Polarity(..), Irregular(..)
  , makeSentence, makePhrase, defIrregular, (<+>)
  ) where

import           Data.Binary
import           Data.Char (isAlphaNum, isSpace, toUpper)
import           Data.Map (Map)
import qualified Data.Map as Map
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

#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 =
    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
  | 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,
                        --   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
  | WWandW ![Part]      -- ^ enumeration
  | WWxW !Part ![Part]  -- ^ collection
  | Wown !Part          -- ^ non-premodifying possesive
  | WownW !Part !Part   -- ^ attributive possesive
  | 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)
  | SubjectVerbSg !Part !Part
                        -- ^ 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)
  | SubjectVVandVSg !Part ![Part]
                        -- ^ a shorthand for \"and\", @Sg3rd@ and @Yes@
  deriving (Int -> Part -> ShowS
[Part] -> ShowS
Part -> String
(Int -> Part -> ShowS)
-> (Part -> String) -> ([Part] -> ShowS) -> Show Part
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Part] -> ShowS
$cshowList :: [Part] -> ShowS
show :: Part -> String
$cshow :: Part -> String
showsPrec :: Int -> Part -> ShowS
$cshowsPrec :: Int -> Part -> ShowS
Show, Part -> Part -> Bool
(Part -> Part -> Bool) -> (Part -> Part -> Bool) -> Eq Part
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Part -> Part -> Bool
$c/= :: Part -> Part -> Bool
== :: Part -> Part -> Bool
$c== :: Part -> Part -> Bool
Eq, Eq Part
Eq Part
-> (Part -> Part -> Ordering)
-> (Part -> Part -> Bool)
-> (Part -> Part -> Bool)
-> (Part -> Part -> Bool)
-> (Part -> Part -> Bool)
-> (Part -> Part -> Part)
-> (Part -> Part -> Part)
-> Ord Part
Part -> Part -> Bool
Part -> Part -> Ordering
Part -> Part -> Part
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Part -> Part -> Part
$cmin :: Part -> Part -> Part
max :: Part -> Part -> Part
$cmax :: Part -> Part -> Part
>= :: Part -> Part -> Bool
$c>= :: Part -> Part -> Bool
> :: Part -> Part -> Bool
$c> :: Part -> Part -> Bool
<= :: Part -> Part -> Bool
$c<= :: Part -> Part -> Bool
< :: Part -> Part -> Bool
$c< :: Part -> Part -> Bool
compare :: Part -> Part -> Ordering
$ccompare :: Part -> Part -> Ordering
$cp1Ord :: Eq Part
Ord, (forall x. Part -> Rep Part x)
-> (forall x. Rep Part x -> Part) -> Generic Part
forall x. Rep Part x -> Part
forall x. Part -> Rep Part x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Part x -> Part
$cfrom :: forall x. Part -> Rep Part x
Generic)

instance Binary Part

instance Read Part where
  readsPrec :: Int -> ReadS Part
readsPrec Int
p String
str = [(Text -> Part
Text Text
x, String
y) | (Text
x, String
y) <- Int -> ReadS Text
forall a. Read a => Int -> ReadS a
readsPrec Int
p String
str]

instance IsString Part where
  fromString :: String -> Part
fromString = Text -> Part
Text (Text -> Part) -> (String -> Text) -> String -> Part
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack

instance Semigroup Part where
  <> :: Part -> Part -> Part
(<>) = Part -> Part -> Part
Append

instance Monoid Part where
  mempty :: Part
mempty = Text -> Part
Text Text
""

#if !(MIN_VERSION_base(4,11,0))
  -- this is redundant starting with base-4.11 / GHC 8.4
  mappend = (<>)
#endif

-- | Persons: singular 1st, singular 3rd and the rest.
data Person = Sg1st | Sg3rd | PlEtc
  deriving (Int -> Person -> ShowS
[Person] -> ShowS
Person -> String
(Int -> Person -> ShowS)
-> (Person -> String) -> ([Person] -> ShowS) -> Show Person
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Person] -> ShowS
$cshowList :: [Person] -> ShowS
show :: Person -> String
$cshow :: Person -> String
showsPrec :: Int -> Person -> ShowS
$cshowsPrec :: Int -> Person -> ShowS
Show, Person -> Person -> Bool
(Person -> Person -> Bool)
-> (Person -> Person -> Bool) -> Eq Person
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Person -> Person -> Bool
$c/= :: Person -> Person -> Bool
== :: Person -> Person -> Bool
$c== :: Person -> Person -> Bool
Eq, Eq Person
Eq Person
-> (Person -> Person -> Ordering)
-> (Person -> Person -> Bool)
-> (Person -> Person -> Bool)
-> (Person -> Person -> Bool)
-> (Person -> Person -> Bool)
-> (Person -> Person -> Person)
-> (Person -> Person -> Person)
-> Ord Person
Person -> Person -> Bool
Person -> Person -> Ordering
Person -> Person -> Person
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Person -> Person -> Person
$cmin :: Person -> Person -> Person
max :: Person -> Person -> Person
$cmax :: Person -> Person -> Person
>= :: Person -> Person -> Bool
$c>= :: Person -> Person -> Bool
> :: Person -> Person -> Bool
$c> :: Person -> Person -> Bool
<= :: Person -> Person -> Bool
$c<= :: Person -> Person -> Bool
< :: Person -> Person -> Bool
$c< :: Person -> Person -> Bool
compare :: Person -> Person -> Ordering
$ccompare :: Person -> Person -> Ordering
$cp1Ord :: Eq Person
Ord, (forall x. Person -> Rep Person x)
-> (forall x. Rep Person x -> Person) -> Generic Person
forall x. Rep Person x -> Person
forall x. Person -> Rep Person x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Person x -> Person
$cfrom :: forall x. Person -> Rep Person x
Generic)

instance Binary Person

-- | Generalized polarity: affirmative, negative, interrogative.
data Polarity = Yes | No | Why
  deriving (Int -> Polarity -> ShowS
[Polarity] -> ShowS
Polarity -> String
(Int -> Polarity -> ShowS)
-> (Polarity -> String) -> ([Polarity] -> ShowS) -> Show Polarity
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Polarity] -> ShowS
$cshowList :: [Polarity] -> ShowS
show :: Polarity -> String
$cshow :: Polarity -> String
showsPrec :: Int -> Polarity -> ShowS
$cshowsPrec :: Int -> Polarity -> ShowS
Show, Polarity -> Polarity -> Bool
(Polarity -> Polarity -> Bool)
-> (Polarity -> Polarity -> Bool) -> Eq Polarity
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Polarity -> Polarity -> Bool
$c/= :: Polarity -> Polarity -> Bool
== :: Polarity -> Polarity -> Bool
$c== :: Polarity -> Polarity -> Bool
Eq, Eq Polarity
Eq Polarity
-> (Polarity -> Polarity -> Ordering)
-> (Polarity -> Polarity -> Bool)
-> (Polarity -> Polarity -> Bool)
-> (Polarity -> Polarity -> Bool)
-> (Polarity -> Polarity -> Bool)
-> (Polarity -> Polarity -> Polarity)
-> (Polarity -> Polarity -> Polarity)
-> Ord Polarity
Polarity -> Polarity -> Bool
Polarity -> Polarity -> Ordering
Polarity -> Polarity -> Polarity
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Polarity -> Polarity -> Polarity
$cmin :: Polarity -> Polarity -> Polarity
max :: Polarity -> Polarity -> Polarity
$cmax :: Polarity -> Polarity -> Polarity
>= :: Polarity -> Polarity -> Bool
$c>= :: Polarity -> Polarity -> Bool
> :: Polarity -> Polarity -> Bool
$c> :: Polarity -> Polarity -> Bool
<= :: Polarity -> Polarity -> Bool
$c<= :: Polarity -> Polarity -> Bool
< :: Polarity -> Polarity -> Bool
$c< :: Polarity -> Polarity -> Bool
compare :: Polarity -> Polarity -> Ordering
$ccompare :: Polarity -> Polarity -> Ordering
$cp1Ord :: Eq Polarity
Ord, (forall x. Polarity -> Rep Polarity x)
-> (forall x. Rep Polarity x -> Polarity) -> Generic Polarity
forall x. Rep Polarity x -> Polarity
forall x. Polarity -> Rep Polarity x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Polarity x -> Polarity
$cfrom :: forall x. Polarity -> Rep Polarity x
Generic)

instance Binary Polarity

-- | Nouns with irregular plural form and nouns with irregular indefinite
-- article.
data Irregular = Irregular
  { Irregular -> Map Text Text
irrPlural     :: Map Text Text
  , Irregular -> Map Text Text
irrIndefinite :: Map Text Text
  }

-- | Default set of words with irregular forms.
defIrregular :: Irregular
defIrregular :: Irregular
defIrregular =
  Irregular :: Map Text Text -> Map Text Text -> Irregular
Irregular {irrPlural :: Map Text Text
irrPlural = Map Text Text
defIrrPlural, irrIndefinite :: Map Text Text
irrIndefinite = Map Text Text
defIrrIndefinite}

-- | Realise a complete sentence, capitalized, ending with a dot.
makeSentence :: Irregular -> [Part] -> Text
makeSentence :: Irregular -> [Part] -> Text
makeSentence Irregular
irr [Part]
l = Text -> Text
capitalize (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Irregular -> [Part] -> Text
makePhrase Irregular
irr [Part]
l Text -> Char -> Text
`T.snoc` Char
'.'

-- | Realise a phrase. The spacing between parts resembles
-- the semantics of @(\<\+\>)@, that is, it ignores empty words.
makePhrase :: Irregular -> [Part] -> Text
makePhrase :: Irregular -> [Part] -> Text
makePhrase Irregular
irr = Text -> [Text] -> Text
T.intercalate (Char -> Text
T.singleton Char
' ') ([Text] -> Text) -> ([Part] -> [Text]) -> [Part] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Irregular -> [Part] -> [Text]
makeParts Irregular
irr

makeParts :: Irregular -> [Part] -> [Text]
makeParts :: Irregular -> [Part] -> [Text]
makeParts Irregular
irr = (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
T.null) ([Text] -> [Text]) -> ([Part] -> [Text]) -> [Part] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Part -> Text) -> [Part] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Irregular -> Part -> Text
makePart Irregular
irr)

-- The semantics of the operations is compositional.
makePart :: Irregular -> Part -> Text
makePart :: Irregular -> Part -> Text
makePart Irregular
irr Part
part = case Part
part of
  String String
t -> String -> Text
T.pack String
t
  Text Text
t -> Text
t
  Cardinal Int
n -> Int -> Text
cardinal Int
n
  Car Int
n -> Int -> Text
forall a. Show a => a -> Text
tshow Int
n
  Ws Part
p -> (Text -> Text) -> Text -> Text
onLastWord (Irregular -> Text -> Text
makePlural Irregular
irr) (Part -> Text
mkPart Part
p)
  CardinalAWs Int
0 Part
p -> Text
"no" Text -> Text -> Text
<+> (Text -> Text) -> Text -> Text
onLastWord (Irregular -> Text -> Text
makePlural Irregular
irr) (Part -> Text
mkPart Part
p)
  CardinalAWs Int
1 Part
p -> Part -> Text
mkPart (Part -> Part
AW Part
p)
  CardinalAWs Int
n Part
p -> Int -> Text
cardinal Int
n Text -> Text -> Text
<+> (Text -> Text) -> Text -> Text
onLastWord (Irregular -> Text -> Text
makePlural Irregular
irr) (Part -> Text
mkPart Part
p)
  CardinalWs Int
1 Part
p -> Int -> Text
cardinal Int
1 Text -> Text -> Text
<+> Part -> Text
mkPart Part
p  -- spelled number
  CardinalWs Int
n Part
p -> Int -> Text
cardinal Int
n Text -> Text -> Text
<+> (Text -> Text) -> Text -> Text
onLastWord (Irregular -> Text -> Text
makePlural Irregular
irr) (Part -> Text
mkPart Part
p)
  CarAWs Int
0 Part
p -> Text
"no" Text -> Text -> Text
<+> (Text -> Text) -> Text -> Text
onLastWord (Irregular -> Text -> Text
makePlural Irregular
irr) (Part -> Text
mkPart Part
p)
  CarAWs Int
1 Part
p -> Part -> Text
mkPart (Part -> Part
AW Part
p)
  CarAWs Int
n Part
p -> Int -> Text
forall a. Show a => a -> Text
tshow Int
n Text -> Text -> Text
<+> (Text -> Text) -> Text -> Text
onLastWord (Irregular -> Text -> Text
makePlural Irregular
irr) (Part -> Text
mkPart Part
p)
  CarWs Int
1 Part
p -> Text
"1" Text -> Text -> Text
<+> Part -> Text
mkPart Part
p
  CarWs Int
n Part
p -> Int -> Text
forall a. Show a => a -> Text
tshow Int
n Text -> Text -> Text
<+> (Text -> Text) -> Text -> Text
onLastWord (Irregular -> Text -> Text
makePlural Irregular
irr) (Part -> Text
mkPart Part
p)
  Car1Ws Int
1 Part
p -> Part -> Text
mkPart Part
p  -- no number, article, anything; useful
  Car1Ws Int
n Part
p -> Int -> Text
forall a. Show a => a -> Text
tshow Int
n Text -> Text -> Text
<+> (Text -> Text) -> Text -> Text
onLastWord (Irregular -> Text -> Text
makePlural Irregular
irr) (Part -> Text
mkPart Part
p)
  Ordinal Int
n -> Int -> Text
ordinal Int
n
  Ord Int
n -> Int -> Text
ordinalNotSpelled Int
n
  AW Part
p -> (Text -> Text) -> Text -> Text
onFirstWord (Irregular -> Text -> Text
addIndefinite Irregular
irr) (Part -> Text
mkPart Part
p)
  WWandW [Part]
lp -> let i :: Text
i = Text
"and" :: Text
                   lt :: [Text]
lt = Irregular -> [Part] -> [Text]
makeParts Irregular
irr [Part]
lp
               in Text -> [Text] -> Text
commas Text
i [Text]
lt
  WWxW Part
x [Part]
lp -> let i :: Text
i = Part -> Text
mkPart Part
x
                   lt :: [Text]
lt = Irregular -> [Part] -> [Text]
makeParts Irregular
irr [Part]
lp
               in Text -> [Text] -> Text
commas Text
i [Text]
lt
  Wown Part
p -> (Text -> Text) -> Text -> Text
onLastWord Text -> Text
nonPremodifying (Part -> Text
mkPart Part
p)
  WownW Part
p1 Part
p2 -> (Text -> Text) -> Text -> Text
onLastWord Text -> Text
attributive (Part -> Text
mkPart Part
p1) Text -> Text -> Text
<+> Part -> Text
mkPart Part
p2
  Phrase [Part]
lp -> Irregular -> [Part] -> Text
makePhrase Irregular
irr [Part]
lp
  Append Part
p1 Part
p2 -> Part -> Text
mkPart Part
p1 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Part -> Text
mkPart Part
p2
  Capitalize Part
p -> Text -> Text
capitalize (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Part -> Text
mkPart Part
p
  SubjectVerb Person
defaultPerson Polarity
Yes Part
s Part
v ->
    Person -> Text -> Text -> Text
subjectVerb Person
defaultPerson (Part -> Text
mkPart Part
s) (Part -> Text
mkPart Part
v)
  SubjectVerb Person
defaultPerson Polarity
No Part
s Part
v ->
    Person -> Text -> Text -> Text
notSubjectVerb Person
defaultPerson (Part -> Text
mkPart Part
s) (Part -> Text
mkPart Part
v)
  SubjectVerb Person
defaultPerson Polarity
Why Part
s Part
v ->
    Person -> Text -> Text -> Text
qSubjectVerb Person
defaultPerson (Part -> Text
mkPart Part
s) (Part -> Text
mkPart Part
v)
  SubjectVerbSg Part
s Part
v ->
    Person -> Text -> Text -> Text
subjectVerb Person
Sg3rd (Part -> Text
mkPart Part
s) (Part -> Text
mkPart Part
v)
  SubjectVVxV Part
x Person
defaultPerson Polarity
Yes Part
s [Part]
vs ->
    Text -> Person -> Text -> [Text] -> Text
subjectVVxV (Part -> Text
mkPart Part
x) Person
defaultPerson (Part -> Text
mkPart Part
s) (Irregular -> [Part] -> [Text]
makeParts Irregular
irr [Part]
vs)
  SubjectVVxV Part
x Person
defaultPerson Polarity
No Part
s [Part]
vs ->
    Text -> Person -> Text -> [Text] -> Text
notSubjectVVxV (Part -> Text
mkPart Part
x) Person
defaultPerson (Part -> Text
mkPart Part
s) (Irregular -> [Part] -> [Text]
makeParts Irregular
irr [Part]
vs)
  SubjectVVxV Part
x Person
defaultPerson Polarity
Why Part
s [Part]
vs ->
    Text -> Person -> Text -> [Text] -> Text
qSubjectVVxV (Part -> Text
mkPart Part
x) Person
defaultPerson (Part -> Text
mkPart Part
s) (Irregular -> [Part] -> [Text]
makeParts Irregular
irr [Part]
vs)
  SubjectVVandVSg Part
s [Part]
vs ->
    Text -> Person -> Text -> [Text] -> Text
subjectVVxV Text
"and" Person
Sg3rd (Part -> Text
mkPart Part
s) (Irregular -> [Part] -> [Text]
makeParts Irregular
irr [Part]
vs)
 where
  mkPart :: Part -> Text
mkPart = Irregular -> Part -> Text
makePart Irregular
irr

onFirstWord :: (Text -> Text) -> Text -> Text
onFirstWord :: (Text -> Text) -> Text -> Text
onFirstWord Text -> Text
f Text
t =
  let (Text
starting, Text
restRaw) = (Char -> Bool) -> Text -> (Text, Text)
T.span Char -> Bool
isWordLetter Text
t
      rest :: Text
rest = (Char -> Bool) -> Text -> Text
T.dropWhile (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isWordLetter) Text
restRaw
      fstarting :: Text
fstarting = Text -> Text
f Text
starting
  in if Text -> Bool
T.null Text
starting
     then Text
t
     else if Text -> Bool
T.null Text
fstarting
          then Text
rest
          else Text -> Text
f Text
starting Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
restRaw

onLastWord :: (Text -> Text) -> Text -> Text
onLastWord :: (Text -> Text) -> Text -> Text
onLastWord Text -> Text
f Text
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 (Text
wordPrefix, Text
nonWordSuffix) =
        let (Text
wordP, Text
nonWordP) = (Char -> Bool) -> Text -> (Text, Text)
T.span (\Char
c -> Char -> Bool
isWordLetter Char
c Bool -> Bool -> Bool
|| Char -> Bool
isSpace Char
c) Text
t
            (Text
wordSpaceR, Text
wordRestR) = (Char -> Bool) -> Text -> (Text, Text)
T.span Char -> Bool
isSpace (Text -> (Text, Text)) -> Text -> (Text, Text)
forall a b. (a -> b) -> a -> b
$ Text -> Text
T.reverse Text
wordP
        in (Text -> Text
T.reverse Text
wordRestR, Text -> Text
T.reverse Text
wordSpaceR Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
nonWordP)
      (Text
spanPrefix, Text
spanRest) = (Char -> Bool) -> Text -> (Text, Text)
T.span Char -> Bool
isWordLetter (Text -> (Text, Text)) -> Text -> (Text, Text)
forall a b. (a -> b) -> a -> b
$ Text -> Text
T.reverse Text
wordPrefix
      (Text
ending, Text
restRaw) = (Text -> Text
T.reverse Text
spanPrefix, Text -> Text
T.reverse Text
spanRest)
      rest :: Text
rest = (Char -> Bool) -> Text -> Text
T.dropWhile (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isWordLetter) Text
restRaw
      fending :: Text
fending = Text -> Text
f Text
ending
      onLast :: Text
onLast = if Text -> Bool
T.null Text
ending
               then Text
wordPrefix
               else if Text -> Bool
T.null Text
fending
                    then Text
rest
                    else Text
restRaw Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
f Text
ending
  in Text
onLast Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
nonWordSuffix

onFirstWordPair :: (Text -> (Text, Text)) -> Text -> (Text, Text)
onFirstWordPair :: (Text -> (Text, Text)) -> Text -> (Text, Text)
onFirstWordPair Text -> (Text, Text)
f Text
t =
  let (Text
starting, Text
restRaw) = (Char -> Bool) -> Text -> (Text, Text)
T.span Char -> Bool
isWordLetter Text
t
      rest :: Text
rest = (Char -> Bool) -> Text -> Text
T.dropWhile (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isWordLetter) Text
restRaw
      (Text
t1, Text
t2) = Text -> (Text, Text)
f Text
starting
  in if Text -> Bool
T.null Text
starting
     then (Text
t, Text
"")
     else if Text -> Bool
T.null Text
t2
          then (Text
t1, Text
rest)
          else (Text
t1, Text
t2 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
restRaw)

isWordLetter :: Char -> Bool
isWordLetter :: Char -> Bool
isWordLetter Char
c = Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\'' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-'

capitalize :: Text -> Text
capitalize :: Text -> Text
capitalize Text
t = case Text -> Maybe (Char, Text)
T.uncons Text
t of
  Maybe (Char, Text)
Nothing        -> Text
T.empty
  Just (Char
c, Text
rest) -> Char -> Text -> Text
T.cons (Char -> Char
toUpper Char
c) Text
rest

makePlural :: Irregular -> Text -> Text
makePlural :: Irregular -> Text -> Text
makePlural Irregular{Map Text Text
irrPlural :: Map Text Text
irrPlural :: Irregular -> Map Text Text
irrPlural} Text
t =
  case Text -> Map Text Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
t Map Text Text
irrPlural of
    Just Text
u  -> Text
u
    Maybe Text
Nothing -> Text -> Text
defaultNounPlural Text
t

addIndefinite :: Irregular -> Text -> Text
addIndefinite :: Irregular -> Text -> Text
addIndefinite Irregular{Map Text Text
irrIndefinite :: Map Text Text
irrIndefinite :: Irregular -> Map Text Text
irrIndefinite} Text
t =
  case Text -> Map Text Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
t Map Text Text
irrIndefinite of
    Just Text
u  -> Text
u Text -> Text -> Text
<+> Text
t
    Maybe Text
Nothing -> Text -> Text
indefiniteDet Text
t Text -> Text -> Text
<+> Text
t

guessPerson :: Person -> Text -> Person
guessPerson :: Person -> Text -> Person
guessPerson Person
defaultPerson Text
"i" = Person
defaultPerson  -- letter 'i', not person 'I'
guessPerson Person
defaultPerson Text
word =
  case Text -> Text
T.toLower Text
word of
    Text
"i"    -> Person
Sg1st
    Text
"he"   -> Person
Sg3rd
    Text
"she"  -> Person
Sg3rd
    Text
"it"   -> Person
Sg3rd
    Text
"we"   -> Person
PlEtc
    Text
"you"  -> Person
PlEtc
    Text
"they" -> Person
PlEtc
    Text
_      -> Person
defaultPerson -- we don't try guessing beyond pronouns

personVerb :: Person -> Text -> Text
personVerb :: Person -> Text -> Text
personVerb Person
Sg1st Text
"be" = Text
"am"
personVerb Person
PlEtc Text
"be" = Text
"are"
personVerb Person
Sg3rd Text
"be" = Text
"is"
personVerb Person
_ Text
"can"    = Text
"can"
personVerb Person
_ Text
"could"  = Text
"could"
personVerb Person
_ Text
"must"   = Text
"must"
personVerb Person
_ Text
"will"   = Text
"will"
personVerb Person
_ Text
"would"  = Text
"would"
personVerb Person
_ Text
"shall"  = Text
"shall"
personVerb Person
_ Text
"should" = Text
"should"
personVerb Person
_ Text
"ought"  = Text
"ought"
personVerb Person
_ Text
"may"    = Text
"may"
personVerb Person
_ Text
"might"  = Text
"might"
personVerb Person
_ Text
"had"    = Text
"had"
personVerb Person
Sg1st Text
v = Text
v
personVerb Person
PlEtc Text
v = Text
v
personVerb Person
Sg3rd Text
"have" = Text
"has"
personVerb Person
Sg3rd Text
v = (Text, Text) -> Text
forall a b. (a, b) -> a
fst (Text -> (Text, Text)
defaultVerbStuff Text
v)

subjectVerb :: Person -> Text -> Text -> Text
subjectVerb :: Person -> Text -> Text -> Text
subjectVerb Person
defaultPerson Text
s Text
v =
  Text
s Text -> Text -> Text
<+> (Text -> Text) -> Text -> Text
onFirstWord (Person -> Text -> Text
personVerb (Person -> Text -> Text) -> Person -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Person -> Text -> Person
guessPerson Person
defaultPerson Text
s) Text
v

subjectVVxV :: Text -> Person -> Text -> [Text] -> Text
subjectVVxV :: Text -> Person -> Text -> [Text] -> Text
subjectVVxV Text
x Person
defaultPerson Text
s [Text]
vs =
  let conjugate :: Text -> Text
conjugate = (Text -> Text) -> Text -> Text
onFirstWord (Person -> Text -> Text
personVerb (Person -> Text -> Text) -> Person -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Person -> Text -> Person
guessPerson Person
defaultPerson Text
s)
  in Text
s Text -> Text -> Text
<+> Text -> [Text] -> Text
commas Text
x ((Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
conjugate [Text]
vs)

notPersonVerb :: Person -> Text -> Text
notPersonVerb :: Person -> Text -> Text
notPersonVerb Person
Sg1st Text
"be" = Text
"am not"
notPersonVerb Person
PlEtc Text
"be" = Text
"aren't"
notPersonVerb Person
Sg3rd Text
"be" = Text
"isn't"
notPersonVerb Person
_ Text
"can"    = Text
"can't"
notPersonVerb Person
_ Text
"could"  = Text
"couldn't"
notPersonVerb Person
_ Text
"must"   = Text
"mustn't"
notPersonVerb Person
_ Text
"will"   = Text
"won't"
notPersonVerb Person
_ Text
"would"  = Text
"wouldn't"
notPersonVerb Person
_ Text
"shall"  = Text
"shan't"
notPersonVerb Person
_ Text
"should" = Text
"shouldn't"
notPersonVerb Person
_ Text
"ought"  = Text
"oughtn't"
notPersonVerb Person
_ Text
"may"    = Text
"may not"
notPersonVerb Person
_ Text
"might"  = Text
"might not"
notPersonVerb Person
_ Text
"had"    = Text
"hadn't"
notPersonVerb Person
Sg1st Text
v = Text
"don't" Text -> Text -> Text
<+> Text
v
notPersonVerb Person
PlEtc Text
v = Text
"don't" Text -> Text -> Text
<+> Text
v
notPersonVerb Person
Sg3rd Text
v = Text
"doesn't" Text -> Text -> Text
<+> Text
v

notSubjectVerb :: Person -> Text -> Text -> Text
notSubjectVerb :: Person -> Text -> Text -> Text
notSubjectVerb Person
defaultPerson Text
s Text
v =
  Text
s Text -> Text -> Text
<+> (Text -> Text) -> Text -> Text
onFirstWord (Person -> Text -> Text
notPersonVerb (Person -> Text -> Text) -> Person -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Person -> Text -> Person
guessPerson Person
defaultPerson Text
s) Text
v

notSubjectVVxV :: Text -> Person -> Text -> [Text] -> Text
notSubjectVVxV :: Text -> Person -> Text -> [Text] -> Text
notSubjectVVxV Text
_ Person
_ Text
s [] = Text
s
notSubjectVVxV Text
x Person
defaultPerson Text
s (Text
v : [Text]
vs) =
  let vNot :: Text
vNot = (Text -> Text) -> Text -> Text
onFirstWord (Person -> Text -> Text
notPersonVerb (Person -> Text -> Text) -> Person -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Person -> Text -> Person
guessPerson Person
defaultPerson Text
s) Text
v
  in Text
s Text -> Text -> Text
<+> Text -> [Text] -> Text
commas Text
x (Text
vNot Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
vs)

qPersonVerb :: Person -> Text -> (Text, Text)
qPersonVerb :: Person -> Text -> (Text, Text)
qPersonVerb Person
Sg1st Text
"be" = (Text
"am", Text
"")
qPersonVerb Person
PlEtc Text
"be" = (Text
"are", Text
"")
qPersonVerb Person
Sg3rd Text
"be" = (Text
"is", Text
"")
qPersonVerb Person
_ Text
"can"    = (Text
"can", Text
"")
qPersonVerb Person
_ Text
"could"  = (Text
"could", Text
"")
qPersonVerb Person
_ Text
"must"   = (Text
"must", Text
"")
qPersonVerb Person
_ Text
"will"   = (Text
"will", Text
"")
qPersonVerb Person
_ Text
"would"  = (Text
"would", Text
"")
qPersonVerb Person
_ Text
"shall"  = (Text
"shall", Text
"")
qPersonVerb Person
_ Text
"should" = (Text
"should", Text
"")
qPersonVerb Person
_ Text
"ought"  = (Text
"ought", Text
"")
qPersonVerb Person
_ Text
"may"    = (Text
"may", Text
"")
qPersonVerb Person
_ Text
"might"  = (Text
"might", Text
"")
qPersonVerb Person
_ Text
"had"    = (Text
"had", Text
"")
qPersonVerb Person
Sg1st Text
v = (Text
"do", Text
v)
qPersonVerb Person
PlEtc Text
v = (Text
"do", Text
v)
qPersonVerb Person
Sg3rd Text
v = (Text
"does", Text
v)

qSubjectVerb :: Person -> Text -> Text -> Text
qSubjectVerb :: Person -> Text -> Text -> Text
qSubjectVerb Person
defaultPerson Text
s Text
v =
  let (Text
v1, Text
v2) = (Text -> (Text, Text)) -> Text -> (Text, Text)
onFirstWordPair (Person -> Text -> (Text, Text)
qPersonVerb (Person -> Text -> (Text, Text)) -> Person -> Text -> (Text, Text)
forall a b. (a -> b) -> a -> b
$ Person -> Text -> Person
guessPerson Person
defaultPerson Text
s) Text
v
  in Text
v1 Text -> Text -> Text
<+> Text
s Text -> Text -> Text
<+> Text
v2

qSubjectVVxV :: Text -> Person -> Text -> [Text] -> Text
qSubjectVVxV :: Text -> Person -> Text -> [Text] -> Text
qSubjectVVxV Text
_ Person
_ Text
s [] = Text
s
qSubjectVVxV Text
x Person
defaultPerson Text
s (Text
v : [Text]
vs) =
  let (Text
v1, Text
v2) = (Text -> (Text, Text)) -> Text -> (Text, Text)
onFirstWordPair (Person -> Text -> (Text, Text)
qPersonVerb (Person -> Text -> (Text, Text)) -> Person -> Text -> (Text, Text)
forall a b. (a -> b) -> a -> b
$ Person -> Text -> Person
guessPerson Person
defaultPerson Text
s) Text
v
      glue :: Text -> Text -> Text
glue = if Text -> Bool
T.null Text
v2 then Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
(<>) else Text -> Text -> Text
(<+>)
  in Text
v1 Text -> Text -> Text
<+> Text
s Text -> Text -> Text
`glue` Text -> [Text] -> Text
commas Text
x (Text
v2 Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
vs)

nonPremodifying :: Text -> Text
nonPremodifying :: Text -> Text
nonPremodifying Text
"who"  = Text
"whose"
nonPremodifying Text
"Who"  = Text
"Whose"
nonPremodifying Text
"I"    = Text
"mine"
nonPremodifying Text
"you"  = Text
"yours"
nonPremodifying Text
"You"  = Text
"Yours"
nonPremodifying Text
"he"   = Text
"his"
nonPremodifying Text
"He"   = Text
"His"
nonPremodifying Text
"she"  = Text
"her"
nonPremodifying Text
"She"  = Text
"Her"
nonPremodifying Text
"it"   = Text
"its"
nonPremodifying Text
"It"   = Text
"Its"
nonPremodifying Text
"we"   = Text
"ours"
nonPremodifying Text
"We"   = Text
"Ours"
nonPremodifying Text
"they" = Text
"theirs"
nonPremodifying Text
"They" = Text
"Theirs"
nonPremodifying Text
t = Text -> Text
defaultPossesive Text
t

attributive :: Text -> Text
attributive :: Text -> Text
attributive Text
"who"  = Text
"whose"
attributive Text
"Who"  = Text
"Whose"
attributive Text
"I"    = Text
"my"
attributive Text
"you"  = Text
"your"
attributive Text
"You"  = Text
"Your"
attributive Text
"he"   = Text
"his"
attributive Text
"He"   = Text
"His"
attributive Text
"she"  = Text
"her"
attributive Text
"She"  = Text
"Her"
attributive Text
"it"   = Text
"its"
attributive Text
"It"   = Text
"Its"
attributive Text
"we"   = Text
"our"
attributive Text
"We"   = Text
"Our"
attributive Text
"they" = Text
"their"
attributive Text
"They" = Text
"Their"
attributive Text
t = Text -> Text
defaultPossesive Text
t

-- TODO: use a suffix tree, to catch ableman, seaman, etc.?
-- | Default set of nouns with irregular plural form.
defIrrPlural :: Map Text Text
defIrrPlural :: Map Text Text
defIrrPlural = [(Text, Text)] -> Map Text Text
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Text, Text)] -> Map Text Text)
-> [(Text, Text)] -> Map Text Text
forall a b. (a -> b) -> a -> b
$ ((Text, Text) -> [(Text, Text)])
-> [(Text, Text)] -> [(Text, Text)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Text, Text) -> [(Text, Text)]
generateCapitalized ([(Text, Text)] -> [(Text, Text)])
-> [(Text, Text)] -> [(Text, Text)]
forall a b. (a -> b) -> a -> b
$
  [ (Text
"bro",         Text
"bros")
  , (Text
"canto",       Text
"cantos")
  , (Text
"homo",        Text
"homos")
  , (Text
"photo",       Text
"photos")
  , (Text
"zero",        Text
"zeros")
  , (Text
"piano",       Text
"pianos")
  , (Text
"portico",     Text
"porticos")
  , (Text
"pro",         Text
"pros")
  , (Text
"quarto",      Text
"quartos")
  , (Text
"kimono",      Text
"kimonos")
  , (Text
"knife",       Text
"knives")
  , (Text
"life",        Text
"lives")
  , (Text
"dwarf",       Text
"dwarfs")  -- not for ME dwarves though
  , (Text
"proof",       Text
"proofs")
  , (Text
"roof",        Text
"roofs")
  , (Text
"turf",        Text
"turfs")
  , (Text
"child",       Text
"children")
  , (Text
"foot",        Text
"feet")
  , (Text
"goose",       Text
"geese")
  , (Text
"louse",       Text
"lice")
  , (Text
"man",         Text
"men")
  , (Text
"mouse",       Text
"mice")
  , (Text
"tooth",       Text
"teeth")
  , (Text
"woman",       Text
"women")
  , (Text
"buffalo",     Text
"buffalo")
  , (Text
"deer",        Text
"deer")
  , (Text
"moose",       Text
"moose")
  , (Text
"sheep",       Text
"sheep")
  , (Text
"bison",       Text
"bison")
  , (Text
"salmon",      Text
"salmon")
  , (Text
"pike",        Text
"pike")
  , (Text
"trout",       Text
"trout")
  , (Text
"swine",       Text
"swine")
  , (Text
"aircraft",    Text
"aircraft")
  , (Text
"watercraft",  Text
"watercraft")
  , (Text
"spacecraft",  Text
"spacecraft")
  , (Text
"hovercraft",  Text
"hovercraft")
  , (Text
"information", Text
"information")
  , (Text
"whiff",       Text
"whiffs")
  , (Text
"graffiti",    Text
"graffiti")
  , (Text
"stomach",     Text
"stomachs")
  ]

generateCapitalized :: (Text, Text) -> [(Text, Text)]
generateCapitalized :: (Text, Text) -> [(Text, Text)]
generateCapitalized (Text
t1, Text
t2) =
  let t1C :: Text
t1C = Text -> Text
capitalize Text
t1
      t2C :: Text
t2C = Text -> Text
capitalize Text
t2
  in if Text
t1 Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
t1C then [(Text
t1, Text
t2)] else [(Text
t1, Text
t2), (Text
t1C, Text
t2C)]

-- | Default set of nouns with irregular indefinite article.
defIrrIndefinite :: Map Text Text
defIrrIndefinite :: Map Text Text
defIrrIndefinite = [(Text, Text)] -> Map Text Text
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
  [ (Text
"SCUBA",        Text
"a")
  , (Text
"HEPA",         Text
"a")
  , (Text
"hour",         Text
"an")
  , (Text
"heir",         Text
"an")
  , (Text
"honour",       Text
"an")
  , (Text
"honor",        Text
"an")
  ]