ViewsSet.hs

-- SPDX-FileCopyrightText: 2022 Oxhead Alpha
-- SPDX-License-Identifier: LicenseRef-MIT-OA

{-# OPTIONS_HADDOCK not-home #-}

-- | Internal helper types and functions for manipulating view sets
module Morley.Michelson.Internal.ViewsSet
  ( module Morley.Michelson.Internal.ViewsSet
  ) where

import Control.Monad.Except (throwError)
import Data.Aeson (FromJSON, ToJSON)
import Data.Coerce (coerce)
import Data.Default (Default(..))
import Data.List.NonEmpty qualified as NE (group)
import Data.Map qualified as Map
import Fmt (Buildable(..), (+|), (|+))

import Morley.Michelson.Internal.ViewName

-- | Type for intermediate coercions between typed and untyped view sets.
-- Intended as an internal helper.
newtype ViewsSetF a = ViewsSetF { unViewsSetF :: Map ViewName a }
  deriving newtype (FromJSON, ToJSON, Default, NFData, Container, ToPairs)
  deriving stock (Eq, Show, Functor)

-- | Errors possible when constructing @ViewsSet@.
data ViewsSetError
  = DuplicatedViewName ViewName
  deriving stock (Show, Eq)

instance Buildable ViewsSetError where
  build = \case
    DuplicatedViewName name -> "Duplicated view name '" +| name |+ "'"

-- | Convenience function to construct 'ViewsSetF'.
mkViewsSet :: (a -> ViewName) -> [a] -> Either ViewsSetError (ViewsSetF a)
mkViewsSet viewName views = do
  ensureNoDuplicates $ viewName <$> views
  pure $ ViewsSetF $ fromList $ views <&> \v -> (viewName v, v)

-- | No views.
emptyViewsSet :: ViewsSetF a
emptyViewsSet = def

-- | Add a view to set.
addViewToSet
  :: (a -> ViewName)
  -> a
  -> ViewsSetF a
  -> Either ViewsSetError (ViewsSetF a)
addViewToSet name v views = do
  let viewName = name v
  when (viewName `Map.member` unViewsSetF views) $
    throwError $ DuplicatedViewName viewName
  pure $ coerce (Map.insert viewName v) views

-- | Find a view in the set.
lookupView :: ViewName -> ViewsSetF a -> Maybe a
lookupView name = Map.lookup name . unViewsSetF

-- | Get all taken names in views set.
viewsSetNames :: ViewsSetF a -> Set ViewName
viewsSetNames = Map.keysSet . unViewsSetF

ensureNoDuplicates :: [ViewName] -> Either ViewsSetError ()
ensureNoDuplicates names =
  forM_ (NE.group $ sort names) \case
    name :| _ : _ -> throwError $ DuplicatedViewName name
    _ :| _ -> pass