diff options
Diffstat (limited to 'src/Data')
| -rw-r--r-- | src/Data/Alias.hs | 124 | ||||
| -rw-r--r-- | src/Data/Name.hs | 19 | ||||
| -rw-r--r-- | src/Data/Person.hs | 49 |
3 files changed, 106 insertions, 86 deletions
diff --git a/src/Data/Alias.hs b/src/Data/Alias.hs index 1a00212..8eec279 100644 --- a/src/Data/Alias.hs +++ b/src/Data/Alias.hs @@ -1,7 +1,10 @@ -module Hakyll.Alias +module Data.Alias ( Aliased (..) , ToAliases (..) , FromAlias (..) + , WithAliases (..) + , withAliases + , NoAliases (..) -- * Containers , AliasMap (..) , buildAliasMap @@ -13,14 +16,18 @@ module Hakyll.Alias 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 +import Data.Map.Strict qualified as M +import Data.Set qualified as S +import Data.Typeable -data WithAliases a x = WithAliases (HS.HashSet a) x - deriving (Foldable, Functor, Generic, Generic1, Ord, Show, Traversable) +data WithAliases a x = WithAliases (Set a) x + deriving stock (Eq, Foldable, Functor, Generic, Generic1, Ord, Show, Traversable) -instance Hashable a => Applicative (WithAliases a) where +withAliases :: (Ord a, ToAliases x a) => Set a -> x -> WithAliases a x +withAliases as x = WithAliases (as <> toAliases x) x + +instance Ord a => Applicative (WithAliases a) where pure = WithAliases mempty WithAliases a1 f <*> WithAliases a2 x = WithAliases (a1 <> a2) (f x) @@ -28,45 +35,42 @@ 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 (FromJSON a, FromJSON x, ToAliases x a, Ord a) => FromJSON (WithAliases a x) where + parseJSON v@(Object o) = withAliases + <$> o .:? "aliases" .!= mempty + <*> parseJSON v <|> o .: "value" + parseJSON v = WithAliases mempty <$> parseJSON v + +instance (ToJSON a, ToJSON x) => ToJSON (WithAliases a x) where + toJSON (WithAliases a x) + | S.null a = toJSON x + | otherwise = case toJSON x of + Object o -> Object $ KM.singleton "aliases" (toJSON a) <> o + v -> object [ "aliases" .= a, "value" .= v ] + + +newtype NoAliases x = NoAliases x + deriving newtype (FromJSON, ToJSON) + deriving stock (Eq, Foldable, Functor, Generic, Generic1, Ord, Show, Traversable) + +instance Ord a => ToAliases (NoAliases x) a where + toAliases _ = mempty + instance (Binary a, Binary x) => Binary (WithAliases a x) -instance (Hashable a) => ToAliases (WithAliases a x) where +instance (Ord a) => ToAliases (WithAliases a x) a 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) + deriving newtype (Bifoldable, Bifunctor, Binary, Eq, Foldable, Functor, Ord) + deriving stock (Generic, Generic1, Show, Traversable) -class (Eq a, Hashable a) => ToAliases x a where - toAliases :: x -> HS.HashSet a +class Ord a => ToAliases x a where + toAliases :: x -> Set a -instance Hashable a => ToAliases a a where - toAliases = HM.singleton -instance (Eq a, Hashable a) => ToAliases (HashSet a) a where +instance Ord a => ToAliases (Set a) a where toAliases = id instance ToAliases x a => ToAliases [x] a where @@ -86,22 +90,52 @@ 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) + +newtype AliasMap a x = AliasMap (Map a x) + deriving newtype (Binary, Foldable, Functor, Semigroup, Monoid) + deriving stock (Show, Traversable) buildAliasMap :: (Foldable t, ToAliases x a) => t x -> AliasMap a x -buildAliasMap = fmap Aliasmap $ foldMap $ \x -> x <$ HS.toMap (toAliases x) +buildAliasMap = fmap AliasMap $ foldMap $ \x -> x <$ 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 +toMap :: Ord a => Set a -> Map a () +toMap = M.fromAscList . fmap (, ()) . S.toAscList +{-# INLINE toMap #-} +findAlias :: Ord a => a -> AliasMap a x -> Either (NoAlias a) x +findAlias a (AliasMap h) = maybe (Left $ NoAlias a) Right $ M.lookup a h + +-- | Throws an error when not found +lookupAlias :: (MonadThrow m, Typeable a, Ord a, Show a, FromAlias b x) => a -> AliasMap a b -> m x +lookupAlias a = either throwM fromAlias . findAlias a + +-- | Uses 'fromAlias' when not found +resolveAlias :: (MonadThrow m, Ord a, FromAlias a x, FromAlias b x) => a -> AliasMap a b -> m x +resolveAlias a = either (\(NoAlias x) -> fromAlias x) fromAlias . findAlias a + +instance (FromJSON a, FromJSON x, ToAliases x a, Ord a) => FromJSON (AliasMap a x) where + parseJSON = fmap b . parseJSON + where + b :: [WithAliases a x] -> AliasMap a x + b = fmap extract . buildAliasMap newtype NoAlias a = NoAlias a - deriving (Eq, Show) + deriving (Eq, Foldable, Functor, Ord, Show, Traversable) -instance Show a => Exception (NoAlias a) where +instance Comonad NoAlias where + extract (NoAlias a) = a + duplicate x = NoAlias x + +instance Applicative NoAlias where + pure = NoAlias + NoAlias f <*> NoAlias x = NoAlias $ f x + +instance (Show a, Typeable a) => Exception (NoAlias a) where displayException (NoAlias a) = show a <> " is not an alias" -missingAlias :: MonadThrow m => a -> m b +-- | Always throws an error +instance (Show a, Typeable a) => FromAlias (NoAlias a) a where + fromAlias = throwM + +missingAlias :: (MonadThrow m, Show a, Typeable a) => a -> m b missingAlias = throwM . NoAlias diff --git a/src/Data/Name.hs b/src/Data/Name.hs index b1f2739..ab49273 100644 --- a/src/Data/Name.hs +++ b/src/Data/Name.hs @@ -5,14 +5,18 @@ module Data.Name , 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 @@ -20,12 +24,15 @@ data Name a = Name { lastName :: !a , firstName :: !a , middleName :: !(Maybe a) - } deriving (Eq, Functor, Foldable, Generic, Generic1, Hashable, Hashable1, Ord, Show, Traversable) + } 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') @@ -40,20 +47,20 @@ instance ToJSON a => ToJSON (Name a) where , "last" .= l ] <> maybe [] (pure . ("middle" .=)) m -instance StringConv s StrictText => ToJSONKey (Name s) where - toJSONKey = showNameLFM . toSL >$< toJSONKey +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 $ fmap toSL . (readNameLFM <|> readNameFML) + fromJSONKey = FromJSONKeyTextParser $ \t -> toSL <<$>> (readNameLFM t <|> readNameFML t) instance StringConv StrictText s => FromJSON (Name s) where - parseJSON (Object v) = fmap toSL $ Name + parseJSON (Object v) = fmap (fmap $ toSL @StrictText) $ Name <$> v .: "first" <*> v .: "last" <*> v .:? "middle" .!= Nothing - parseJSON (String t) = toSL <$> readNameLFM t + parseJSON (String t) = toSL <<$>> (readNameLFM t <|> readNameFML t) parseJSON _ = empty diff --git a/src/Data/Person.hs b/src/Data/Person.hs index e7c5f76..c829fc4 100644 --- a/src/Data/Person.hs +++ b/src/Data/Person.hs @@ -10,13 +10,18 @@ import Prolog import Data.Aeson import Data.Alias import Data.Name -import Data.HashMap.Strict qualified as HM +import Data.Set qualified as S import Network.URI (URI) +import Network.URI qualified as URI import Text.Blaze import Text.Blaze.Html import Text.Blaze.Html5 (a) import Text.Blaze.Html5.Attributes (href) +-- | Huh, I guess I need a version bump for this guy? +instance FromJSON URI where + parseJSON = withText "URI" $ maybe (fail "Invalid URI") pure . URI.parseURI . toSL + data Person a = Person { name :: !(Name a) , webpage :: !(Maybe URI) @@ -32,39 +37,13 @@ personHtml (Person n w) = personFromName :: Name a -> Person a personFromName n = Person n Nothing +instance FromJSON (Name a) => FromJSON (Person a) where + parseJSON = withObject "Person" $ \v -> Person + <$> v .: "name" + <*> v .:? "webpage" .!= Nothing +instance Ord (Name a) => ToAliases (Person a) (Name a) where + toAliases = S.singleton . name -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 +instance FromAlias (Name a) (Person a) where + fromAlias n = pure $ Person n Nothing |