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