From 7085075a90c03025e5d53a256d42e317805b879b Mon Sep 17 00:00:00 2001 From: Chris Wells Date: Tue, 4 Feb 2025 10:26:00 -0600 Subject: Working on alias resolution --- src/Data/Alias.hs | 107 +++++++++++++++++++++++++++++++++++++++++++++++++++++ src/Data/Name.hs | 30 ++++++++++++++- src/Data/Person.hs | 45 ++++++++++++++++++++-- 3 files changed, 178 insertions(+), 4 deletions(-) create mode 100644 src/Data/Alias.hs (limited to 'src/Data') 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 -- cgit v1.2.3