{-# LANGUAGE TypeOperators, ScopedTypeVariables, FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fcontext-stack=30 #-}
-- No overlapping instances!
-- Adding a special case to an existing library of overloaded functions,
-- *without* overlapping instances
-- The special case will overlap with the general case implemented
-- in the library. Since the library uses associated data types,
-- overlapping instances are not permitted.
-- This code relies on TTypeable to solve the problem without
-- overlapping. OverlappingInstances are avoidable.
-- This code is a OverlappingInstances-free version of GMapSpec.hs
-- The latter code was developed in response to a real-life optimization
-- problem posed by Ryan Newton on the Haskell-Cafe
-- mailing list on June 4, 2010:
-- http://www.haskell.org/pipermail/haskell-cafe/2010-June/078590.html
module GMapSpec where
import TTypeable (TYPEOF, Member, AC_TREPEQ, TC_code,
TRN_arrow, HTrue, HFalse, S, NIL, (:/))
import Data.Int
import Data.Word
import Data.Bits
import qualified Data.IntMap as IM
import Prelude hiding (lookup)
-- The library in question is GMap, of
-- generic maps specialized to the data type of the key.
-- To make the present code self-contained we reproduce the
-- representative bits of the library:
-- ===== Begin a simplified GMap package
-- A simplified class GMapKey
class GMapKey t where
data GMap t :: * -> *
empty :: GMap t v
lookup :: t -> GMap t v -> Maybe v
instance GMapKey Int16 where
data GMap Int16 v = GMI16 (IM.IntMap v)
empty = GMI16 $ IM.empty
lookup k (GMI16 m) = IM.lookup (fromIntegral k) m
instance GMapKey Int32 where
data GMap Int32 v = GMI32 (IM.IntMap v)
empty = GMI32 $ IM.empty
lookup k (GMI32 m) = IM.lookup (fromIntegral k) m
-- Generic instance for pairs
instance (GMapKey a, GMapKey b) => GMapKey (a, b) where
data GMap (a, b) v = GMapPair (GMap a (GMap b v))
empty = GMapPair $ empty
lookup k (GMapPair m) = error "Invoking the generic instance for pairs"
-- ===== End the simplified GMap package
-- If the key is a pair of Int8s or Int16s or some other data
-- that can be packed in a single Int32, we are better off
-- packing the pair into an Int32 and using the GMapKey Int32
-- instance rather than using the generic GMap instance for
-- the pairs. Alas, we cannot add the desired specific
-- (Int8,Int8) instance for GMapKey because it overlaps
-- the existing generic GMapKey (a,b) instance.
-- Since GMapKey has an associated data type GMap, overlapping
-- instances are not allowed.
-- The following is an optimization, which should appear in a different
-- module. The optimization should not disturb the original GMap code.
-- The following optimization is Ryan Newton's code
-- A class for values that fit within one word
class FitInWord v where
toWord :: v -> Word
fromWord :: Word -> v
instance FitInWord (Int16,Int16) where
toWord (a,b) = shiftL (fromIntegral a) 16 + (fromIntegral b)
fromWord n = (fromIntegral$ shiftR n 16,
fromIntegral$ n .&. 0xFFFF)
-- Now we wish to define optimized instances of GMapKey for
-- pairs of items that fit within a word.
-- The following answers Ryan Newton's question.
-- We `override' GMapKey by defining our own, local GMapKey
-- class.
-- Normally, the original GMapKey would be in a separate module,
-- which we import with qualification. Our local GMapKey would be
-- unqualified.
-- To avoid splitting this example code into modules, we
-- define the `local' GMapKey as GMapKey'.
class GMapKey' t where
data GMap' t :: * -> *
empty' :: GMap' t v
lookup' :: t -> GMap' t v -> Maybe v
-- Auxiliary type class, with an extra parameter that tells
-- if the key fits within a word.
-- This extra parameter removes the overloading.
class GMapKeyAux fits t where
data GMapAux fits t :: * -> *
empty_aux :: fits -> GMapAux fits t v
lookup_aux :: fits -> t -> GMapAux fits t v -> Maybe v
type OptimalPairs = TYPEOF (Int16,Int16) :/ NIL -- add more
-- Checking if the type t is the optimal pair,
-- and getting GMapKeyAux to analyze the result
instance (fits ~ (Member AC_TREPEQ (TYPEOF t) OptimalPairs),
GMapKeyAux fits t)
=> GMapKey' t where
newtype GMap' t v =
GM (GMapAux (Member AC_TREPEQ (TYPEOF t) OptimalPairs) t v)
empty' = GM (empty_aux (undefined::fits))
lookup' k (GM m) = lookup_aux (undefined::fits) k m
-- A special pair, of values that fit within a word
instance FitInWord pair => GMapKeyAux HTrue pair where
newtype GMapAux HTrue pair v = GMapInt (IM.IntMap v) deriving Show
empty_aux _ = GMapInt IM.empty
lookup_aux _ k (GMapInt m) = IM.lookup (fromIntegral$ toWord k) m
-- For all other types, re-direct to the original GMap
instance GMapKey t => GMapKeyAux HFalse t where
newtype GMapAux HFalse t v = GFwd (GMap t v)
empty_aux _ = GFwd empty
lookup_aux _ k (GFwd m) = lookup k m
-- tests
-- A specific instance is chosen
test1 = let m = empty' in
lookup' (1::Int16,2::Int16) m
-- Nothing
-- A general pair instance is chosen
test2 = let m = empty' in
lookup' (1::Int32,2::Int16) m
-- *** Exception: Invoking the generic instance for pairs
-- The approach is not limited to pairs and can be used
-- to convert a range of specific data types of keys to a more packed
-- representation.
-- Should be derived
data TRN_pair
type instance TC_code TRN_pair = S (TC_code TRN_arrow)
type instance TYPEOF (a,b) = (TRN_pair, (TYPEOF a) :/ (TYPEOF b) :/ NIL)
data TRN_Int16
type instance TC_code TRN_Int16 = S (TC_code TRN_pair)
type instance TYPEOF Int16 = (TRN_Int16, NIL)
data TRN_Int32
type instance TC_code TRN_Int32 = S (TC_code TRN_Int16)
type instance TYPEOF Int32 = (TRN_Int32, NIL)
-- similarly for Int8, Word8, etc.