morpheus-graphql-core-0.18.0: src/Data/Mergeable/OrdMap.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Mergeable.OrdMap
  ( OrdMap (..),
  )
where

import Control.Monad.Except (MonadError)
import qualified Data.HashMap.Lazy as HM
import Data.Mergeable.Internal.Merge (Merge (..))
import Data.Mergeable.Internal.NameCollision (NameCollision (..))
import Data.Mergeable.Internal.Resolution
  ( Indexed (..),
    indexed,
  )
import Data.Mergeable.IsMap
  ( FromList (..),
    IsMap (..),
  )
import Data.Morpheus.Ext.Empty (Empty (..))
import Language.Haskell.TH.Syntax (Lift (..))
import Relude hiding (fromList)

-- OrdMap
newtype OrdMap k a = OrdMap
  { mapEntries :: HashMap k (Indexed k a)
  }
  deriving
    ( Show,
      Eq,
      Functor,
      Traversable,
      Empty
    )

instance (Lift a, Lift k, Eq k, Hashable k) => Lift (OrdMap k a) where
  lift (OrdMap x) = [|OrdMap (HM.fromList ls)|]
    where
      ls = HM.toList x

#if MIN_VERSION_template_haskell(2,16,0)
  liftTyped (OrdMap x) = [||OrdMap (HM.fromList ls)||]
    where
      ls = HM.toList x
#endif

instance (Eq k, Hashable k) => Foldable (OrdMap k) where
  foldMap f = foldMap f . getElements

getElements :: (Eq k, Hashable k) => OrdMap k b -> [b]
getElements = fmap indexedValue . sortOn index . toList . mapEntries

instance (Eq k, Hashable k) => IsMap k (OrdMap k) where
  unsafeFromList = OrdMap . HM.fromList . fmap withKey . indexed
    where
      withKey idx = (indexedKey idx, idx)
  singleton k x = OrdMap $ HM.singleton k (Indexed 0 k x)
  lookup key OrdMap {mapEntries} = indexedValue <$> lookup key mapEntries

instance (NameCollision e a, Eq k, Hashable k, Monad m, MonadError e m) => Merge m (OrdMap k a) where
  merge (OrdMap x) (OrdMap y) = OrdMap <$> merge x (fmap (shiftIndexes (HM.size x)) y)

shiftIndexes :: Int -> Indexed k a -> Indexed k a
shiftIndexes n Indexed {..} = Indexed {index = index + n, ..}

instance
  ( Hashable k,
    Eq k,
    NameCollision e a,
    MonadError e m
  ) =>
  FromList m OrdMap k a
  where
  fromList = fmap OrdMap . fromList . map xyz . indexed
    where
      xyz x = (indexedKey x, x)