{-# LANGUAGE CPP #-}
module Control.Super.Plugin.InstanceDict
( InstanceDict
, emptyInstDict, insertInstDict
, lookupInstDict, lookupInstDictByTyCon
, allInstDictTyCons
, instDictToList ) where
import Data.Maybe ( maybeToList, fromMaybe )
#if MIN_VERSION_GLASGOW_HASKELL(8,0,0,0)
import Data.Semigroup ( Semigroup(..) )
#endif
import Class ( Class )
import InstEnv ( ClsInst )
import TyCon ( TyCon )
import qualified Outputable as O
import qualified Control.Super.Plugin.Collection.Set as S
import qualified Control.Super.Plugin.Collection.Map as M
newtype InstanceDict = InstanceDict (M.Map TyCon (M.Map Class ClsInst))
instance Monoid InstanceDict where
mappend (InstanceDict dictA) (InstanceDict dictB) = InstanceDict $ foldr (\tc dictAB -> M.insert tc (combineClsMaps tc) dictAB) M.empty keysAB
where
keysAB :: [TyCon]
keysAB = S.toList $ M.keysSet dictA `S.union` M.keysSet dictB
combineClsMaps :: TyCon -> M.Map Class ClsInst
combineClsMaps tc = (fromMaybe M.empty $ M.lookup tc dictA) `M.union` (fromMaybe M.empty $ M.lookup tc dictB)
mempty = emptyInstDict
#if MIN_VERSION_GLASGOW_HASKELL(8,0,0,0)
instance Semigroup InstanceDict where
(<>) = mappend
#endif
instance O.Outputable InstanceDict where
ppr (InstanceDict instDict) = O.text "InstanceDict " O.<> O.parens (O.ppr instDict)
emptyInstDict :: InstanceDict
emptyInstDict = InstanceDict $ M.empty
insertInstDict :: TyCon -> Class -> ClsInst -> InstanceDict -> InstanceDict
insertInstDict tc cls inst (InstanceDict instDict)
= InstanceDict $ M.insert tc (M.insert cls inst (fromMaybe M.empty $ M.lookup tc instDict)) instDict
lookupInstDict :: TyCon -> Class -> InstanceDict -> Maybe ClsInst
lookupInstDict tc cls (InstanceDict instDict) = do
clsDict <- M.lookup tc instDict
M.lookup cls clsDict
allInstDictTyCons :: InstanceDict -> S.Set TyCon
allInstDictTyCons (InstanceDict instDict) = M.keysSet instDict
lookupInstDictByTyCon :: TyCon -> InstanceDict -> M.Map Class ClsInst
lookupInstDictByTyCon tc (InstanceDict instDict) = fromMaybe M.empty $ M.lookup tc instDict
instDictToList :: InstanceDict -> [((TyCon, Class), ClsInst)]
instDictToList dict@(InstanceDict instDict) = do
tc <- M.keys instDict
cls <- M.keys $ fromMaybe M.empty $ M.lookup tc instDict
clsInst <- maybeToList $ lookupInstDict tc cls dict
return ( (tc , cls) , clsInst )