1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
|
module Data.Name
( Name (..)
, Name_
-- * Parsers
, readNameLFM
, readNameFML
-- * Writers
, showNameLFM
, showNameFML
, renderNameLFM
, renderNameFML
) where
import Prolog
import Data.Aeson
import Data.Alias
import Data.Char (isSpace)
import Data.List qualified as L
import Data.Set qualified as S
import Data.Text qualified as T
data Name a = Name
{ lastName :: !a
, firstName :: !a
, middleName :: !(Maybe a)
} deriving (Eq, Functor, Foldable, Generic, Generic1, Ord, Show, Traversable)
type Name_ = Name StrictText
instance Binary a => Binary (Name a)
instance Ord a => ToAliases (Name a) (Name a) where
toAliases = S.singleton
instance Applicative Name where
pure a = Name a a (pure a)
Name l f m <*> Name l' f' m' = Name (l l') (f f') (m <*> m')
instance ToJSON a => ToJSON (Name a) where
toJSON (Name l f m) = object $
[ "first" .= f
, "last" .= l
] <> maybe [] (pure . ("middle" .=)) m
toEncoding (Name l f m) = pairs $ fold $
[ "first" .= f
, "last" .= l
] <> maybe [] (pure . ("middle" .=)) m
instance (StringConv s StrictText, ToJSON s) => ToJSONKey (Name s) where
toJSONKey = showNameLFM . fmap toSL >$< toJSONKey
instance StringConv StrictText s => FromJSONKey (Name s) where
fromJSONKey = FromJSONKeyTextParser $ \t -> toSL <<$>> (readNameLFM t <|> readNameFML t)
instance StringConv StrictText s => FromJSON (Name s) where
parseJSON (Object v) = fmap (fmap $ toSL @StrictText) $ Name
<$> v .: "first"
<*> v .: "last"
<*> v .:? "middle" .!= Nothing
parseJSON (String t) = toSL <<$>> (readNameLFM t <|> readNameFML t)
parseJSON _ = empty
readNameLFM :: Alternative m => StrictText -> m Name_
readNameLFM t = T.map (\c -> if c == '~' then ' ' else c) <<$>>
case T.break (== ',') t of
(l, fm)
| T.null l -> empty
| otherwise -> case T.dropWhile ((||) <$> isSpace <*> (== ',')) fm of
fm'
| T.null fm' -> empty
| otherwise -> case T.break isSpace fm' of
(f, m) -> pure $ Name l f $ case T.dropWhile isSpace m of
x | T.null x -> Nothing
| otherwise -> Just x
readNameFML :: Alternative m => StrictText -> m Name_
readNameFML t = T.map (\c -> if c == '~' then ' ' else c) <<$>>
case T.words t of
[] -> empty
(f:xs) -> case unsnoc xs of
Nothing -> empty
Just (m, l) -> pure $ Name f l $ case m of
[] -> Nothing
_ -> Just $ T.unwords m
showNameLFM :: Name_ -> StrictText
showNameLFM (Name l f m) = stt l <> ", " <> stt f <> maybe "" (\x -> " " <> stt x) m
showNameFML :: Name_ -> StrictText
showNameFML (Name l f m) = stt f <> maybe " " (\x -> " " <> stt x <> " ") m <> stt l
renderNameLFM :: (Semigroup a, IsString a) => Name a -> a
renderNameLFM (Name l f m) = l <> ", " <> f <> maybe "" (\x -> " " <> x) m
renderNameFML :: (Semigroup a, IsString a) => Name a -> a
renderNameFML (Name l f m) = f <> maybe " " (\x -> " " <> x <> " ") m <> l
-- Helpers
unsnoc :: [a] -> Maybe ([a],a)
unsnoc = foldr (\x -> Just . maybe ([], x) (\(~(a, b)) -> (x : a, b))) Nothing
{-# INLINABLE unsnoc #-}
stt :: StrictText -> StrictText
stt = T.map $ \c -> if isSpace c then '~' else c
{-# INLINABLE stt #-}
|
