Working on alias resolution

1 files changed, 42 insertions, 3 deletions

diff --git a/src/Data/Person.hs b/src/Data/Person.hs
index a649c07..e7c5f76 100644
--- a/src/Data/Person.hs
+++ b/src/Data/Person.hs
@@ -7,7 +7,10 @@ module Data.Person
     ) 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
@@ -17,15 +20,51 @@ import Text.Blaze.Html5.Attributes (href)
 data Person a = Person
     { name :: !(Name a)
     , webpage :: !(Maybe URI)
-    , aliases :: ![Name a]
     } deriving (Eq, Functor, Foldable, Generic, Ord, Show, Traversable)
 
 instance Binary a => Binary (Person a)
 
 personHtml :: (ToMarkup a) => Person a -> Html
-personHtml (Person n w _) =
+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 [n]
+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