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
deriving instance Data TyGamInfo

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

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

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

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

{-# LINE 93 "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 116 "src/ehc/Gam/TyGam.chs" #-}
tyGamLookup :: HsName -> TyGam -> Maybe TyGamInfo
tyGamLookup = gamLookup

{-# LINE 142 "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 218 "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

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

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

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