ClassDefaultGam.hs

module UHC.Light.Compiler.Gam.ClassDefaultGam
( ClassDefaultGamInfo (..)
, ClassDefaultGam
, clDfGamLookupDefault )
where
import UHC.Light.Compiler.Base.Common
import UHC.Light.Compiler.Base.TermLike
import UHC.Light.Compiler.Base.HsName.Builtin
import UHC.Light.Compiler.Gam
import UHC.Light.Compiler.Ty
import UHC.Light.Compiler.VarMp
import UHC.Util.Substitutable
import UHC.Light.Compiler.Ty.FitsInCommon2
import UHC.Light.Compiler.Ty.FitsIn
import Data.Maybe
import Control.Monad
import UHC.Util.Binary
import UHC.Util.Serialize



{-# LINE 34 "src/ehc/Gam/ClassDefaultGam.chs" #-}
-- If this changes, also change {%{EH}ConfigInternalVersions}
data ClassDefaultGamInfo
  = ClassDefaultGamInfo
      { cldiDefaultTypes	:: [Ty]
      }
      deriving (Typeable)

{-# LINE 45 "src/ehc/Gam/ClassDefaultGam.chs" #-}
type ClassDefaultGam = Gam HsName ClassDefaultGamInfo

{-# LINE 53 "src/ehc/Gam/ClassDefaultGam.chs" #-}
-- | Lookup a matching default for a predicate
clDfGamLookupDefault
  :: ( VarLookup gm TyVarId VarMpInfo
     -- , VarLookup gm Ty VarMpInfo
     , VarLookupCmb VarMp gm
     , SubstVarKey gm ~ VarId, SubstVarVal gm ~ VarMpInfo
     )
     => FIIn' gm -> Pred -> ClassDefaultGam
     -> Maybe VarMp
clDfGamLookupDefault fi pr clDfGam
  = case pr of
      Pred_Class t | isJust mbConArgs
        -> do (ClassDefaultGamInfo {cldiDefaultTypes = (tg:_)}) <- gamLookup nm clDfGam
              (_,tyVarMp) <- fitPredIntoPred fi pr (Pred_Class $ appCon1App nm tg)
              return tyVarMp
        where mbConArgs@(~(Just (nm,args))) = appMbConApp t
      _ -> Nothing

{-# LINE 77 "src/ehc/Gam/ClassDefaultGam.chs" #-}
instance Serialize ClassDefaultGamInfo where
  sput (ClassDefaultGamInfo a) = sput a
  sget = liftM ClassDefaultGamInfo sget