Crazy labels stuff

LabeledContainers.hs

{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module LabeledContainers
  ( Map
  , HashMap
  , Set
  , Hashable
  , asMap
  , asHashMap
  , asSet
  ) where

import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import Data.Map (Map)
import Data.Set (Set)
import GHC.Records
import GHC.OverloadedLabels
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HM
import Data.Hashable (Hashable)

instance Ord k => HasField "insert" (Map k v) (k -> v -> Map k v) where
  getField m k v = Map.insert k v m
instance Ord k => HasField "lookup" (Map k v) (k -> Maybe v) where
  getField m k = Map.lookup k m

instance (Hashable k, Eq k) => HasField "insert" (HashMap k v) (k -> v -> HashMap k v) where
  getField m k v = HM.insert k v m
instance (Hashable k, Eq k) => HasField "lookup" (HashMap k v) (k -> Maybe v) where
  getField m k = HM.lookup k m

instance Ord v => HasField "insert" (Set v) (v -> Set v) where
  getField s v = Set.insert v s
instance Ord v => HasField "member" (Set v) (v -> Bool) where
  getField s v = Set.member v s

instance forall x r a. HasField x r a => IsLabel x (r -> a) where
  fromLabel = getField @x

asMap :: Map k v -> Map k v
asMap = id

asHashMap :: HashMap k v -> HashMap k v
asHashMap = id

asSet :: Set v -> Set v
asSet = id

Main.hs

#!/usr/bin/env stack
{- stack --resolver lts-12.0 script
   --package containers
   --package unordered-containers
   --package hashable
-}
{-# LANGUAGE OverloadedLabels #-}
import LabeledContainers

main :: IO ()
main = do
  print $ #lookup (#insert (asMap mempty) "Hello" "World") "Hello"
  print $ #lookup (#insert (asHashMap mempty) "Hello" "World") "Hello"
  print $ #member (#insert (asSet mempty) "Hello") "Hello"