A lot of work on aliases and the like

1 files changed, 21 insertions, 9 deletions

diff --git a/src/Data/Alias.hs b/src/Data/Alias.hs
index 8eec279..270ce1f 100644
--- a/src/Data/Alias.hs
+++ b/src/Data/Alias.hs
@@ -5,9 +5,13 @@ module Data.Alias
     , WithAliases (..)
     , withAliases
     , NoAliases (..)
+    , TrivialAlias (..)
     -- * Containers
     , AliasMap (..)
     , buildAliasMap
+    , findAlias
+    , lookupAlias
+    , resolveAlias
     -- * Errors
     , NoAlias (..)
     , missingAlias
@@ -24,7 +28,7 @@ import Data.Typeable
 data WithAliases a x = WithAliases (Set a) x
     deriving stock (Eq, Foldable, Functor, Generic, Generic1, Ord, Show, Traversable)
 
-withAliases :: (Ord a, ToAliases x a) => Set a -> x -> WithAliases a x
+withAliases :: ToAliases x a => Set a -> x -> WithAliases a x
 withAliases as x = WithAliases (as <> toAliases x) x
 
 instance Ord a => Applicative (WithAliases a) where
@@ -80,14 +84,21 @@ instance ToAliases x a => ToAliases [x] a where
 class FromAlias a x where
     fromAlias :: MonadThrow m => a -> m x
 
-instance FromAlias a a where
-    fromAlias = pure
+newtype TrivialAlias a = TrivialAlias { getTrivialAlias :: a }
+    deriving stock (Generic, Show)
+    deriving newtype (Eq, Binary, Ord)
+
+instance FromAlias (TrivialAlias a) a where
+    fromAlias = pure . getTrivialAlias
+
+-- 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
+    fromAlias = either fromAlias pure . unAliased
 
 
 
@@ -96,7 +107,8 @@ newtype AliasMap a x = AliasMap (Map a x)
     deriving stock (Show, Traversable)
 
 buildAliasMap :: (Foldable t, ToAliases x a) => t x -> AliasMap a x
-buildAliasMap = fmap AliasMap $ foldMap $ \x -> x <$ toMap (toAliases x)
+buildAliasMap = fmap AliasMap $ foldMap $ (<$) <*> toMap . toAliases
+{-# INLINE buildAliasMap #-}
 
 toMap :: Ord a => Set a -> Map a ()
 toMap = M.fromAscList . fmap (, ()) . S.toAscList
@@ -106,12 +118,12 @@ 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
+lookupAlias :: (MonadThrow m, Typeable a, Ord a, Show a) => a -> AliasMap a x -> m x
+lookupAlias a = either throwM pure . 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
+resolveAlias :: (MonadThrow m, Ord a, FromAlias a x) => a -> AliasMap a x -> m x
+resolveAlias a = either (\(NoAlias x) -> fromAlias x) pure . findAlias a
 
 instance (FromJSON a, FromJSON x, ToAliases x a, Ord a) => FromJSON (AliasMap a x) where
     parseJSON = fmap b . parseJSON