Working on alias resolution

1 files changed, 107 insertions, 0 deletions

diff --git a/src/Data/Alias.hs b/src/Data/Alias.hs
new file mode 100644
index 0000000..1a00212
--- /dev/null
+++ b/src/Data/Alias.hs
@@ -0,0 +1,107 @@
+module Hakyll.Alias
+    ( Aliased (..)
+    , ToAliases (..)
+    , FromAlias (..)
+    -- * Containers
+    , AliasMap (..)
+    , buildAliasMap
+    -- * Errors
+    , NoAlias (..)
+    , missingAlias
+    ) where
+
+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
+
+
+data WithAliases a x = WithAliases (HS.HashSet a) x
+    deriving (Foldable, Functor, Generic, Generic1, Ord, Show, Traversable)
+
+instance Hashable a => Applicative (WithAliases a) where
+    pure = WithAliases mempty
+    WithAliases a1 f <*> WithAliases a2 x = WithAliases (a1 <> a2) (f x)
+
+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 (Binary a, Binary x) => Binary (WithAliases a x)
+
+instance (Hashable a) => ToAliases (WithAliases a x) 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)
+
+class (Eq a, Hashable a) => ToAliases x a where
+    toAliases :: x -> HS.HashSet a
+
+instance Hashable a => ToAliases a a where
+    toAliases = HM.singleton
+
+instance (Eq a, Hashable a) => ToAliases (HashSet a) a where
+    toAliases = id
+
+instance ToAliases x a => ToAliases [x] a where
+    toAliases = foldMap toAliases
+
+
+class FromAlias a x where
+    fromAlias :: MonadThrow m => a -> m x
+
+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
+
+
+newtype AliasMap a x = AliasMap (HM.HashMap a x)
+    deriving newtype (Binary, Foldable, Functor, Generic, Generic1, Semigroup, Monoid, Traversable)
+    deriving stock (Show)
+
+buildAliasMap :: (Foldable t, ToAliases x a) => t x -> AliasMap a x
+buildAliasMap = fmap Aliasmap $ foldMap $ \x -> x <$ HS.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
+
+
+newtype NoAlias a = NoAlias a
+    deriving (Eq, Show)
+
+instance Show a => Exception (NoAlias a) where
+    displayException (NoAlias a) = show a <> " is not an alias"
+
+missingAlias :: MonadThrow m => a -> m b
+missingAlias = throwM . NoAlias