Working on the alias module

1 files changed, 79 insertions, 45 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