Working on alias resolution

3 files changed, 178 insertions, 4 deletions

diff --git a/src/Data/Alias.hs b/src/Data/Alias.hs
new file mode 100644
index 0000000..1a00212
--- /dev/null
+++ b/src/Data/Alias.hs
@@ -0,0 +1,107 @@
+module Hakyll.Alias
+    ( Aliased (..)
+    , ToAliases (..)
+    , FromAlias (..)
+    -- * Containers
+    , AliasMap (..)
+    , buildAliasMap
+    -- * Errors
+    , NoAlias (..)
+    , missingAlias
+    ) where
+
+import Prolog
+import Data.Aeson
+import Data.Aeson.KeyMap qualified as KM
+import Data.HashMap.Strict qualified as HM
+import Data.HashSet qualified as HS
+
+
+data WithAliases a x = WithAliases (HS.HashSet a) x
+    deriving (Foldable, Functor, Generic, Generic1, Ord, Show, Traversable)
+
+instance Hashable a => Applicative (WithAliases a) where
+    pure = WithAliases mempty
+    WithAliases a1 f <*> WithAliases a2 x = WithAliases (a1 <> a2) (f x)
+
+instance Comonad (WithAliases a) where
+    extract (WithAliases _ x) = x
+    duplicate = join (<$)
+
+-- instance (FromJSON a, FromJSON x, Hashable a) => FromJSON (WithAliases a x) where
+--     parseJSON (Object v) = WithAliases
+--         <$> v .:? "aliases" .!= mempty
+--         <*> (parseJSON (Object v) <|> v .: "value")
+--     parseJSON v = WithAliases mempty <$> parseJSON v
+
+-- instance (ToJSON a, ToJSON x) => ToJSON (WithAliases a x) where
+--     toJSON (WithAliases a x)
+--       | HS.null a = toJSON x
+--       | otherwise = case toJSON x of
+--                       Object o -> Object $ KM.singleton "aliases" (toJSON a) <> o
+--                       v -> object
+--                             [ "aliases" .= a
+--                             , "value" .= v
+--                             ]
+    -- toEncoding (WithAliases a x)
+    --   | HS.null a = toEncoding x
+    --   | otherwise = case toEncoding
+
+
+aliases :: WithAliases a x -> HS.HashSet a
+aliases (WithAliases h _) = h
+
+instance (Binary a, Binary x) => Binary (WithAliases a x)
+
+instance (Hashable a) => ToAliases (WithAliases a x) where
+    toAliases (WithAliases h _) = h
+
+newtype Aliased a x = Aliased { unAliased :: Either a x }
+    deriving newtype (Bifoldable, Bifunctor, Bitraversable, Binary, Eq, Foldable, Functor, Generic, Generic1, Hashable, Ord, Traversable)
+    deriving stock (Show)
+
+class (Eq a, Hashable a) => ToAliases x a where
+    toAliases :: x -> HS.HashSet a
+
+instance Hashable a => ToAliases a a where
+    toAliases = HM.singleton
+
+instance (Eq a, Hashable a) => ToAliases (HashSet a) a where
+    toAliases = id
+
+instance ToAliases x a => ToAliases [x] a where
+    toAliases = foldMap toAliases
+
+
+class FromAlias a x where
+    fromAlias :: MonadThrow m => a -> m x
+
+instance FromAlias a a where
+    fromAlias = pure
+
+instance (FromAlias a x, FromAlias b x) => FromAlias (Either a b) x where
+    fromAlias = either fromAlias fromAlias
+
+instance FromAlias a x => FromAlias (Aliased a x) x where
+    fromAlias = fromAlias . unAliased
+
+
+newtype AliasMap a x = AliasMap (HM.HashMap a x)
+    deriving newtype (Binary, Foldable, Functor, Generic, Generic1, Semigroup, Monoid, Traversable)
+    deriving stock (Show)
+
+buildAliasMap :: (Foldable t, ToAliases x a) => t x -> AliasMap a x
+buildAliasMap = fmap Aliasmap $ foldMap $ \x -> x <$ HS.toMap (toAliases x)
+
+lookupAlias :: (MonadThrow m, Hashable a, Show a) => a -> AliasMap a x -> m x
+lookupAlias a (AliasMap h) = maybe (throwM $ NoAlias a) pure $ HM.lookup a h
+
+
+newtype NoAlias a = NoAlias a
+    deriving (Eq, Show)
+
+instance Show a => Exception (NoAlias a) where
+    displayException (NoAlias a) = show a <> " is not an alias"
+
+missingAlias :: MonadThrow m => a -> m b
+missingAlias = throwM . NoAlias
diff --git a/src/Data/Name.hs b/src/Data/Name.hs
index 9572709..b1f2739 100644
--- a/src/Data/Name.hs
+++ b/src/Data/Name.hs
@@ -10,6 +10,7 @@ module Data.Name
     ) where
 
 import Prolog
+import Data.Aeson
 import Data.Char (isSpace)
 import Data.List qualified as L
 import Data.Text qualified as T
@@ -19,7 +20,7 @@ data Name a = Name
     { lastName :: !a
     , firstName :: !a
     , middleName :: !(Maybe a)
-    } deriving (Eq, Functor, Foldable, Generic, Generic1, Ord, Show, Traversable)
+    } deriving (Eq, Functor, Foldable, Generic, Generic1, Hashable, Hashable1, Ord, Show, Traversable)
 
 type Name_ = Name StrictText
 
@@ -29,6 +30,33 @@ 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 => ToJSONKey (Name s) where
+    toJSONKey = showNameLFM . toSL >$< toJSONKey
+
+instance StringConv StrictText s => FromJSONKey (Name s) where
+    fromJSONKey = FromJSONKeyTextParser $ fmap toSL . (readNameLFM <|> readNameFML)
+
+
+
+instance StringConv StrictText s => FromJSON (Name s) where
+    parseJSON (Object v) = fmap toSL $ Name
+        <$> v .: "first"
+        <*> v .: "last"
+        <*> v .:? "middle" .!= Nothing
+    parseJSON (String t) = toSL <$> readNameLFM t
+    parseJSON _ = empty
+
+
 
 readNameLFM :: Alternative m => StrictText -> m Name_
 readNameLFM t = T.map (\c -> if c == '~' then ' ' else c) <<$>>
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