Working on the alias module

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