fix: read ImplicitMap lawfully

Previously, the read instance could be used to break invariants.
This commit is contained in:
vegowotenks 2025-08-12 14:41:47 +02:00
parent fd715d99e0
commit d38c30e318

View file

@ -1,27 +1,41 @@
{-# LANGUAGE Safe #-} {-# LANGUAGE Safe #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-} -- for KeyType
{-# LANGUAGE StandaloneDeriving #-} -- specify instance contexts
{-# LANGUAGE FlexibleContexts #-} -- use non type-variable argument in instance head {-# LANGUAGE FlexibleContexts #-} -- use non type-variable argument in instance head
{-# LANGUAGE UndecidableInstances #-} -- use type family in instance head {-# LANGUAGE UndecidableInstances #-} -- use type family in instance head
{-# LANGUAGE InstanceSigs #-}
-- | A Map that derives the keys for the mapping from the items. -- | A Map that derives the keys for the mapping from the items.
module Data.Map.Implicit (ImplicitMap(), get, ImplicitKeyOf(..), empty) where module Data.Map.Implicit (ImplicitMap(), get, ImplicitKeyOf(..), empty) where
import Data.Kind (Type, Constraint) import Data.Kind (Type, Constraint)
import Data.Map (Map) import Data.Map (Map)
import Text.Show (Show (show))
import Data.String (String)
import Control.Category ((.), Category (id))
import Data.Map qualified as Map import Data.Map qualified as Map
import Text.Show (Show) import Text.Read (Read (readPrec), ReadPrec)
import Text.Read (Read) import Data.List qualified as List
import Control.Arrow (Arrow ((&&&)))
import Data.Functor ((<$>))
import Data.Ord (Ord) import Data.Ord (Ord)
type ImplicitMap :: Type -> Type type ImplicitMap :: Type -> Type
type role ImplicitMap nominal type role ImplicitMap nominal
newtype ImplicitMap v = ImplicitMap { get :: Map (KeyType v) v } newtype ImplicitMap v = ImplicitMap { get :: Map (KeyType v) v }
deriving stock instance (Show (KeyType v), Show v) => Show (ImplicitMap v) type ImplicitMapElems :: Type -> Type
deriving stock instance (Read (KeyType v), Ord (KeyType v), Read v) => Read (ImplicitMap v) type role ImplicitMapElems representational
newtype ImplicitMapElems v = ImplicitMapElems { elems :: [v] }
deriving stock (Show, Read)
instance (Show v) => Show (ImplicitMap v) where
show :: ImplicitMap v -> String
show = show . ImplicitMapElems . Map.elems . get
instance (Read v, ImplicitKeyOf v, Ord (KeyType v)) => Read (ImplicitMap v) where
readPrec :: ReadPrec (ImplicitMap v)
readPrec = ImplicitMap . Map.fromList . List.map (keyOf &&& id) . elems <$> readPrec
type ImplicitKeyOf :: Type -> Constraint type ImplicitKeyOf :: Type -> Constraint
class ImplicitKeyOf v where class ImplicitKeyOf v where
type KeyType v :: Type type KeyType v :: Type
keyOf :: v -> KeyType v keyOf :: v -> KeyType v