{-# 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.