{-# LANGUAGE DeriveGeneric #-}
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))
import Data.Semigroup
#endif
data Part =
String !String
| Text !Text
| Cardinal !Int
| Car !Int
| Ws !Part
| CardinalAWs !Int !Part
| CardinalWs !Int !Part
| CarAWs !Int !Part
| CarWs !Int !Part
| Car1Ws !Int !Part
| Ordinal !Int
| Ord !Int
| AW !Part
| WWandW ![Part]
| WWxW !Part ![Part]
| Wown !Part
| WownW !Part !Part
| Append !Part !Part
| Phrase ![Part]
| Capitalize !Part
| SubjectVerb !Person !Polarity !Part !Part
| SubjectVerbSg !Part !Part
| SubjectVVxV !Part !Person !Polarity !Part ![Part]
| SubjectVVandVSg !Part ![Part]
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))
mappend = (<>)
#endif
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
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
data Irregular = Irregular
{ Irregular -> Map Text Text
irrPlural :: Map Text Text
, Irregular -> Map Text Text
irrIndefinite :: Map Text Text
}
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}
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
'.'
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)
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
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
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 =
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
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
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
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")
, (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)]
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")
]