{-# LANGUAGE FlexibleInstances, FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE OverlappingInstances #-}

-- Adding a special case to an existing library of overloaded functions

-- 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
-- demonstrates a work-around.
-- It 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 Data.Int
import Data.Word
import Data.Bits
import qualified Data.IntMap as IM

-- 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

-- Define our own product type, to avoid overlapping instances with the
-- general GMapKey for pairs
-- It's a newtype: it has no run-time overhead
newtype OptimalPair a b = OptimalPair (a,b)

instance FitInWord (a,b) => GMapKey (OptimalPair a b) where
  data GMap (OptimalPair a b) v  = GMapInt (IM.IntMap v) deriving Show
  empty                   = GMapInt IM.empty
  lookup (OptimalPair k) (GMapInt m)  = IM.lookup (fromIntegral$ toWord k) m

-- Auxiliary class to choose the appropriate pair

class ChoosePairRepr a b pr | a b -> pr where
    choose_pair  :: (a,b) -> pr
    choosen_pair :: pr -> (a,b)

instance ChoosePairRepr Int16 Int16 (OptimalPair Int16 Int16) where
    choose_pair = OptimalPair
    choosen_pair (OptimalPair p) = p

-- Repeat the above for all other optimal pairs:
-- (Int8, Int16), (Int16, Int8), etc.
-- Template Haskell is very good to generate all such boiler-plate instances

-- Choose a generic pair for all other pairs of values
instance pr ~ (a,b) => ChoosePairRepr a b pr where
    choose_pair   = id
    choosen_pair  = id

-- tests

-- A specific instance is chosen
test1 = let m = empty in
        GMapSpec.lookup (choose_pair (1::Int16,2::Int16)) m
-- Nothing

-- A general pair instance is chosen
test2 = let m = empty in
        GMapSpec.lookup (choose_pair (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.