{-# 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 p :: Int
p str :: String
str = [(Text -> Part
Text Text
x, String
y) | (x :: Text
x, y :: 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 ""
#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 =
$WIrregular :: 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 irr :: Irregular
irr l :: [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` '.'
makePhrase :: Irregular -> [Part] -> Text
makePhrase :: Irregular -> [Part] -> Text
makePhrase irr :: Irregular
irr = Text -> [Text] -> Text
T.intercalate (Char -> Text
T.singleton ' ') ([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 irr :: 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 irr :: Irregular
irr part :: Part
part = case Part
part of
String t :: String
t -> String -> Text
T.pack String
t
Text t :: Text
t -> Text
t
Cardinal n :: Int
n -> Int -> Text
cardinal Int
n
Car n :: Int
n -> Int -> Text
forall a. Show a => a -> Text
tshow Int
n
Ws p :: Part
p -> (Text -> Text) -> Text -> Text
onLastWord (Irregular -> Text -> Text
makePlural Irregular
irr) (Part -> Text
mkPart Part
p)
CardinalAWs 0 p :: Part
p -> "no" Text -> Text -> Text
<+> (Text -> Text) -> Text -> Text
onLastWord (Irregular -> Text -> Text
makePlural Irregular
irr) (Part -> Text
mkPart Part
p)
CardinalAWs 1 p :: Part
p -> Part -> Text
mkPart (Part -> Part
AW Part
p)
CardinalAWs n :: Int
n p :: 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 1 p :: Part
p -> Int -> Text
cardinal 1 Text -> Text -> Text
<+> Part -> Text
mkPart Part
p
CardinalWs n :: Int
n p :: 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 0 p :: Part
p -> "no" Text -> Text -> Text
<+> (Text -> Text) -> Text -> Text
onLastWord (Irregular -> Text -> Text
makePlural Irregular
irr) (Part -> Text
mkPart Part
p)
CarAWs 1 p :: Part
p -> Part -> Text
mkPart (Part -> Part
AW Part
p)
CarAWs n :: Int
n p :: 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 1 p :: Part
p -> "1" Text -> Text -> Text
<+> Part -> Text
mkPart Part
p
CarWs n :: Int
n p :: 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 1 p :: Part
p -> Part -> Text
mkPart Part
p
Car1Ws n :: Int
n p :: 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 n :: Int
n -> Int -> Text
ordinal Int
n
Ord n :: Int
n -> Int -> Text
ordinalNotSpelled Int
n
AW p :: Part
p -> (Text -> Text) -> Text -> Text
onFirstWord (Irregular -> Text -> Text
addIndefinite Irregular
irr) (Part -> Text
mkPart Part
p)
WWandW lp :: [Part]
lp -> let i :: Text
i = "and" :: Text
lt :: [Text]
lt = Irregular -> [Part] -> [Text]
makeParts Irregular
irr [Part]
lp
in Text -> [Text] -> Text
commas Text
i [Text]
lt
WWxW x :: Part
x lp :: [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 p :: Part
p -> (Text -> Text) -> Text -> Text
onLastWord Text -> Text
nonPremodifying (Part -> Text
mkPart Part
p)
WownW p1 :: Part
p1 p2 :: Part
p2 -> (Text -> Text) -> Text -> Text
onLastWord Text -> Text
attributive (Part -> Text
mkPart Part
p1) Text -> Text -> Text
<+> Part -> Text
mkPart Part
p2
Phrase lp :: [Part]
lp -> Irregular -> [Part] -> Text
makePhrase Irregular
irr [Part]
lp
Append p1 :: Part
p1 p2 :: Part
p2 -> Part -> Text
mkPart Part
p1 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Part -> Text
mkPart Part
p2
Capitalize p :: Part
p -> Text -> Text
capitalize (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Part -> Text
mkPart Part
p
SubjectVerb defaultPerson :: Person
defaultPerson Yes s :: Part
s v :: Part
v ->
Person -> Text -> Text -> Text
subjectVerb Person
defaultPerson (Part -> Text
mkPart Part
s) (Part -> Text
mkPart Part
v)
SubjectVerb defaultPerson :: Person
defaultPerson No s :: Part
s v :: Part
v ->
Person -> Text -> Text -> Text
notSubjectVerb Person
defaultPerson (Part -> Text
mkPart Part
s) (Part -> Text
mkPart Part
v)
SubjectVerb defaultPerson :: Person
defaultPerson Why s :: Part
s v :: Part
v ->
Person -> Text -> Text -> Text
qSubjectVerb Person
defaultPerson (Part -> Text
mkPart Part
s) (Part -> Text
mkPart Part
v)
SubjectVerbSg s :: Part
s v :: Part
v ->
Person -> Text -> Text -> Text
subjectVerb Person
Sg3rd (Part -> Text
mkPart Part
s) (Part -> Text
mkPart Part
v)
SubjectVVxV x :: Part
x defaultPerson :: Person
defaultPerson Yes s :: Part
s vs :: [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 x :: Part
x defaultPerson :: Person
defaultPerson No s :: Part
s vs :: [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 x :: Part
x defaultPerson :: Person
defaultPerson Why s :: Part
s vs :: [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 s :: Part
s vs :: [Part]
vs ->
Text -> Person -> Text -> [Text] -> Text
subjectVVxV "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 f :: Text -> Text
f t :: Text
t =
let (starting :: Text
starting, restRaw :: 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 f :: Text -> Text
f t :: Text
t =
let (wordPrefix :: Text
wordPrefix, nonWordSuffix :: Text
nonWordSuffix) =
let (wordP :: Text
wordP, nonWordP :: Text
nonWordP) = (Char -> Bool) -> Text -> (Text, Text)
T.span (\c :: Char
c -> Char -> Bool
isWordLetter Char
c Bool -> Bool -> Bool
|| Char -> Bool
isSpace Char
c) Text
t
(wordSpaceR :: Text
wordSpaceR, wordRestR :: 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)
(spanPrefix :: Text
spanPrefix, spanRest :: 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
(ending :: Text
ending, restRaw :: 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 f :: Text -> (Text, Text)
f t :: Text
t =
let (starting :: Text
starting, restRaw :: 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
(t1 :: Text
t1, t2 :: Text
t2) = Text -> (Text, Text)
f Text
starting
in if Text -> Bool
T.null Text
starting
then (Text
t, "")
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 c :: Char
c = Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\'' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '-'
capitalize :: Text -> Text
capitalize :: Text -> Text
capitalize t :: Text
t = case Text -> Maybe (Char, Text)
T.uncons Text
t of
Nothing -> Text
T.empty
Just (c :: Char
c, rest :: 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} t :: 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 u :: Text
u -> Text
u
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} t :: 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 u :: Text
u -> Text
u Text -> Text -> Text
<+> Text
t
Nothing -> Text -> Text
indefiniteDet Text
t Text -> Text -> Text
<+> Text
t
guessPerson :: Person -> Text -> Person
guessPerson :: Person -> Text -> Person
guessPerson defaultPerson :: Person
defaultPerson "i" = Person
defaultPerson
guessPerson defaultPerson :: Person
defaultPerson word :: Text
word =
case Text -> Text
T.toLower Text
word of
"i" -> Person
Sg1st
"he" -> Person
Sg3rd
"she" -> Person
Sg3rd
"it" -> Person
Sg3rd
"we" -> Person
PlEtc
"you" -> Person
PlEtc
"they" -> Person
PlEtc
_ -> Person
defaultPerson
personVerb :: Person -> Text -> Text
personVerb :: Person -> Text -> Text
personVerb Sg1st "be" = "am"
personVerb PlEtc "be" = "are"
personVerb Sg3rd "be" = "is"
personVerb _ "can" = "can"
personVerb _ "could" = "could"
personVerb _ "must" = "must"
personVerb _ "will" = "will"
personVerb _ "would" = "would"
personVerb _ "shall" = "shall"
personVerb _ "should" = "should"
personVerb _ "ought" = "ought"
personVerb _ "may" = "may"
personVerb _ "might" = "might"
personVerb _ "had" = "had"
personVerb Sg1st v :: Text
v = Text
v
personVerb PlEtc v :: Text
v = Text
v
personVerb Sg3rd "have" = "has"
personVerb Sg3rd v :: 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 defaultPerson :: Person
defaultPerson s :: Text
s v :: 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 x :: Text
x defaultPerson :: Person
defaultPerson s :: Text
s vs :: [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 Sg1st "be" = "am not"
notPersonVerb PlEtc "be" = "aren't"
notPersonVerb Sg3rd "be" = "isn't"
notPersonVerb _ "can" = "can't"
notPersonVerb _ "could" = "couldn't"
notPersonVerb _ "must" = "mustn't"
notPersonVerb _ "will" = "won't"
notPersonVerb _ "would" = "wouldn't"
notPersonVerb _ "shall" = "shan't"
notPersonVerb _ "should" = "shouldn't"
notPersonVerb _ "ought" = "oughtn't"
notPersonVerb _ "may" = "may not"
notPersonVerb _ "might" = "might not"
notPersonVerb _ "had" = "hadn't"
notPersonVerb Sg1st v :: Text
v = "don't" Text -> Text -> Text
<+> Text
v
notPersonVerb PlEtc v :: Text
v = "don't" Text -> Text -> Text
<+> Text
v
notPersonVerb Sg3rd v :: Text
v = "doesn't" Text -> Text -> Text
<+> Text
v
notSubjectVerb :: Person -> Text -> Text -> Text
notSubjectVerb :: Person -> Text -> Text -> Text
notSubjectVerb defaultPerson :: Person
defaultPerson s :: Text
s v :: 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 _ _ s :: Text
s [] = Text
s
notSubjectVVxV x :: Text
x defaultPerson :: Person
defaultPerson s :: Text
s (v :: Text
v : vs :: [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 Sg1st "be" = ("am", "")
qPersonVerb PlEtc "be" = ("are", "")
qPersonVerb Sg3rd "be" = ("is", "")
qPersonVerb _ "can" = ("can", "")
qPersonVerb _ "could" = ("could", "")
qPersonVerb _ "must" = ("must", "")
qPersonVerb _ "will" = ("will", "")
qPersonVerb _ "would" = ("would", "")
qPersonVerb _ "shall" = ("shall", "")
qPersonVerb _ "should" = ("should", "")
qPersonVerb _ "ought" = ("ought", "")
qPersonVerb _ "may" = ("may", "")
qPersonVerb _ "might" = ("might", "")
qPersonVerb _ "had" = ("had", "")
qPersonVerb Sg1st v :: Text
v = ("do", Text
v)
qPersonVerb PlEtc v :: Text
v = ("do", Text
v)
qPersonVerb Sg3rd v :: Text
v = ("does", Text
v)
qSubjectVerb :: Person -> Text -> Text -> Text
qSubjectVerb :: Person -> Text -> Text -> Text
qSubjectVerb defaultPerson :: Person
defaultPerson s :: Text
s v :: Text
v =
let (v1 :: Text
v1, v2 :: 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 _ _ s :: Text
s [] = Text
s
qSubjectVVxV x :: Text
x defaultPerson :: Person
defaultPerson s :: Text
s (v :: Text
v : vs :: [Text]
vs) =
let (v1 :: Text
v1, v2 :: 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 "who" = "whose"
nonPremodifying "Who" = "Whose"
nonPremodifying "I" = "mine"
nonPremodifying "you" = "yours"
nonPremodifying "You" = "Yours"
nonPremodifying "he" = "his"
nonPremodifying "He" = "His"
nonPremodifying "she" = "her"
nonPremodifying "She" = "Her"
nonPremodifying "it" = "its"
nonPremodifying "It" = "Its"
nonPremodifying "we" = "ours"
nonPremodifying "We" = "Ours"
nonPremodifying "they" = "theirs"
nonPremodifying "They" = "Theirs"
nonPremodifying t :: Text
t = Text -> Text
defaultPossesive Text
t
attributive :: Text -> Text
attributive :: Text -> Text
attributive "who" = "whose"
attributive "Who" = "Whose"
attributive "I" = "my"
attributive "you" = "your"
attributive "You" = "Your"
attributive "he" = "his"
attributive "He" = "His"
attributive "she" = "her"
attributive "She" = "Her"
attributive "it" = "its"
attributive "It" = "Its"
attributive "we" = "our"
attributive "We" = "Our"
attributive "they" = "their"
attributive "They" = "Their"
attributive t :: 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
$
[ ("bro", "bros")
, ("canto", "cantos")
, ("homo", "homos")
, ("photo", "photos")
, ("zero", "zeros")
, ("piano", "pianos")
, ("portico", "porticos")
, ("pro", "pros")
, ("quarto", "quartos")
, ("kimono", "kimonos")
, ("knife", "knives")
, ("life", "lives")
, ("dwarf", "dwarfs")
, ("proof", "proofs")
, ("roof", "roofs")
, ("turf", "turfs")
, ("child", "children")
, ("foot", "feet")
, ("goose", "geese")
, ("louse", "lice")
, ("man", "men")
, ("mouse", "mice")
, ("tooth", "teeth")
, ("woman", "women")
, ("buffalo", "buffalo")
, ("deer", "deer")
, ("moose", "moose")
, ("sheep", "sheep")
, ("bison", "bison")
, ("salmon", "salmon")
, ("pike", "pike")
, ("trout", "trout")
, ("swine", "swine")
, ("aircraft", "aircraft")
, ("watercraft", "watercraft")
, ("spacecraft", "spacecraft")
, ("hovercraft", "hovercraft")
, ("information", "information")
, ("whiff", "whiffs")
, ("graffiti", "graffiti")
]
generateCapitalized :: (Text, Text) -> [(Text, Text)]
generateCapitalized :: (Text, Text) -> [(Text, Text)]
generateCapitalized (t1 :: Text
t1, t2 :: 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
[ ("SCUBA", "a")
, ("HEPA", "a")
, ("hour", "an")
, ("heir", "an")
, ("honour", "an")
, ("honor", "an")
]