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
|
module Data.Person
( Person (..)
, personHtml
, personFromName
, Name (..)
, URI
) where
import Prolog
import Data.Aeson
import Data.Alias
import Data.Name
import Data.HashMap.Strict qualified as HM
import Network.URI (URI)
import Text.Blaze
import Text.Blaze.Html
import Text.Blaze.Html5 (a)
import Text.Blaze.Html5.Attributes (href)
data Person a = Person
{ name :: !(Name a)
, webpage :: !(Maybe URI)
} deriving (Eq, Functor, Foldable, Generic, Ord, Show, Traversable)
instance Binary a => Binary (Person a)
personHtml :: (ToMarkup a) => Person a -> Html
personHtml (Person n w) =
let withLink = maybe id (\x -> a ! href (toValue x)) w
in withLink $ renderNameFML $ toMarkup <$> n
personFromName :: Name a -> Person a
personFromName n = Person n Nothing
instance (FromJSON (Name a), Hashable (Name a)) => FromJSON (WithAliases (Name a) (Person a)) where
parseJSON = withObject "Person" $ \v -> do
n <- v .: "name"
w <- v .:? "webpage" .!= Nothing
as <- v .:? "aliases" .!= mempty
pure $ WithAliases (HS.fromList $ n : as) (Person n w)
instance (FromJSON (Name a), Hashable (Name a)) => FromJSON (AliasMap (Name a) (Person a)) where
parseJSON = fmap b . parseJSON
where
b :: [WithAliases (Name a) (Person a)] -> AliasMap (Name a) (Person a)
b = buildAliasMap
-- instance (StringConv StrictText a, Hashable a) => FromJSON (AliasMap (Name a) (Person a)) where
-- parseJSON v =
-- -- m >>= traverse x >>= pure . AliasMap . mk
-- where
-- m :: Parser (HM.HashMap (Name StrictText) Value)
-- m = parseJSON v
-- x :: Value -> Parser (Maybe URI, [Name StrictText])
-- x (Object o) = (,)
-- <$> o .:? "webpage" .!= Nothing
-- <*> o .:? "aliases" .!= mempty
-- x s@(String _) = (,) <$> (Just <$> parseJSON s) <*> pure mempty
-- x a@(Array _) = (,) <$> pure Nothing <*> parseJSON a
-- mk :: (StringConv StrictText t, Hashable t) => HM.HashMap (Name StrictText) (Maybe URI, [Name StrictText]) -> HM.HashMap (Name t) (Person t)
-- mk hm =
-- let personify :: (Name a, (Maybe URI, [Name a])) -> ([Name a], Person a)
-- personify (n, (w, ns)) = (n : ns, Person n w)
-- in foldMap ((\(ns,p) -> HM.fromList $ (, (toSL <$> p)) . fmap toSL <$> ns ) . personify) $ HM.toList hm
-- -- instance ToJSON a => ToJSON (Person a) where
|
