TyGam.hs

module UHC.Light.Compiler.Gam.TyGam
( TyGamInfo (..)
, emptyTGI
, TyGam
, tyGamLookupErr
, mkTGIData
, mkTGI
, initTyGam
, tyGamLookup )
where
import UHC.Util.Pretty
import UHC.Util.Utils
import UHC.Light.Compiler.Base.Common
import UHC.Light.Compiler.Base.TermLike
import UHC.Light.Compiler.Base.HsName.Builtin
import UHC.Light.Compiler.Ty
import UHC.Light.Compiler.Ty.Pretty
import UHC.Light.Compiler.Gam
import UHC.Light.Compiler.Error
import qualified Data.Set as Set
import UHC.Light.Compiler.VarMp
import UHC.Light.Compiler.Substitutable
import UHC.Light.Compiler.Ty.Trf.Quantify
import Control.Monad
import UHC.Util.Binary
import UHC.Util.Serialize







{-# LINE 40 "src/ehc/Gam/TyGam.chs" #-}
-- If this changes, also change {%{EH}ConfigInternalVersions}
data TyGamInfo
  = TyGamInfo
      { tgiTy :: !Ty
      }
      deriving Show

{-# LINE 51 "src/ehc/Gam/TyGam.chs" #-}
deriving instance Typeable TyGamInfo

{-# LINE 55 "src/ehc/Gam/TyGam.chs" #-}
mkTGIData :: Ty -> Ty -> TyGamInfo
mkTGIData t _ = TyGamInfo t

{-# LINE 60 "src/ehc/Gam/TyGam.chs" #-}
mkTGI :: Ty -> TyGamInfo
mkTGI t = mkTGIData t Ty_Any

{-# LINE 65 "src/ehc/Gam/TyGam.chs" #-}
emptyTGI :: TyGamInfo
emptyTGI
  = TyGamInfo
      Ty_Any

{-# LINE 74 "src/ehc/Gam/TyGam.chs" #-}
type TyGam = Gam HsName TyGamInfo

{-# LINE 92 "src/ehc/Gam/TyGam.chs" #-}
tyGamLookupErr :: HsName -> TyGam -> (TyGamInfo,ErrL)
tyGamLookupErr n g
  = case tyGamLookup n g of
      Nothing  -> (emptyTGI,[rngLift emptyRange mkErr_NamesNotIntrod "type" [n]])
      Just tgi -> (tgi,[])

{-# LINE 115 "src/ehc/Gam/TyGam.chs" #-}
tyGamLookup :: HsName -> TyGam -> Maybe TyGamInfo
tyGamLookup = gamLookup

{-# LINE 141 "src/ehc/Gam/TyGam.chs" #-}
initTyGam :: TyGam
initTyGam
  = assocLToGam
      [ (hsnArrow			, mkTGI (appCon hsnArrow))
      , (hsnInt				, mkTGI tyInt)
      , (hsnChar			, mkTGI tyChar)
      , (hsnRow				, mkTGI (appCon hsnUnknown))
      , (hsnRec				, mkTGI (appCon hsnRec))
      , (hsnSum				, mkTGI (appCon hsnSum))
      , (hsnPrArrow			, mkTGI (appCon hsnPrArrow))
      , (hsnEqTilde			, mkTGI (appCon hsnEqTilde))
      , (hsnInteger			, mkTGI tyInteger		)
      , (hsnAddrUnboxed		, mkTGI (appCon hsnAddrUnboxed  )	)
      ]

{-# LINE 217 "src/ehc/Gam/TyGam.chs" #-}
instance VarUpdatable TyGamInfo VarMp where
  s `varUpd`  tgi         =   tgi { tgiTy = s `varUpd` tgiTy tgi }
  s `varUpdCyc` tgi         =   substLift tgiTy (\i x -> i {tgiTy = x}) varUpdCyc s tgi

type instance ExtrValVarKey TyGamInfo = TyVarId

instance VarExtractable TyGamInfo where
  varFreeSet tgi         =   varFreeSet (tgiTy tgi)

{-# LINE 230 "src/ehc/Gam/TyGam.chs" #-}
instance PP TyGamInfo where
  pp tgi = ppTy (tgiTy tgi)

{-# LINE 243 "src/ehc/Gam/TyGam.chs" #-}
instance Serialize TyGamInfo where
  sput (TyGamInfo a) = sput a
  sget = liftM TyGamInfo sget