summaryrefslogtreecommitdiff
path: root/src/Data/Alias.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Data/Alias.hs')
-rw-r--r--src/Data/Alias.hs30
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