ValGam.hs

module UHC.Light.Compiler.Gam.ValGam
( ValGamInfo (..), ValGam
, valGamLookupTy
, valGamMapTy
, valGamLookup
, valGamTyOfDataCon
, valGamTyOfDataFld
, vgiGetSet
, valGamLookupTyDefault
, valGamDoWithVarMp )
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/ValGam.chs" #-}
-- If this changes, also change {%{EH}ConfigInternalVersions}
data ValGamInfo
  = ValGamInfo
      { vgiTy :: Ty }		-- strictness has negative mem usage effect. Why??
      deriving Show

type ValGam = Gam HsName ValGamInfo

{-# LINE 52 "src/ehc/Gam/ValGam.chs" #-}
deriving instance Typeable ValGamInfo
deriving instance Data ValGamInfo

{-# LINE 57 "src/ehc/Gam/ValGam.chs" #-}
vgiGetSet = (vgiTy,(\x i -> i {vgiTy = x}))

{-# LINE 66 "src/ehc/Gam/ValGam.chs" #-}
valGamLookupTy :: HsName -> ValGam -> (Ty,ErrL)
valGamLookupTy n g
  =  case valGamLookup n g of
       Nothing    ->  (Ty_Any,[rngLift emptyRange mkErr_NamesNotIntrod "value" [n]])
       Just vgi   ->  (vgiTy vgi,[])

{-# LINE 74 "src/ehc/Gam/ValGam.chs" #-}
-- | lookup Ty in ValGam, defaulting to Ty_Any
valGamLookupTyDefault :: HsName -> ValGam -> Ty
valGamLookupTyDefault n g = maybe (Ty_Dbg $ "valGamLookupTyDefault: " ++ show n) vgiTy $ valGamLookup n g

{-# LINE 80 "src/ehc/Gam/ValGam.chs" #-}
valGamLookup :: HsName -> ValGam -> Maybe ValGamInfo
valGamLookup nm g
  =  case gamLookup nm g of
       Nothing
         |  hsnIsProd nm
                 -> let pr = mkPr nm in mkRes (tyProdArgs pr `appArr` pr)
         |  hsnIsUn nm && hsnIsProd (hsnUnUn nm)
                 -> let pr = mkPr (hsnUnUn nm) in mkRes ([pr] `appArr` pr)
         where  mkPr nm  = mkTyFreshProd (hsnProdArity nm)
                mkRes t  = Just (ValGamInfo (tyQuantifyClosed t))
       Just vgi  -> Just vgi
       _         -> Nothing

{-# LINE 102 "src/ehc/Gam/ValGam.chs" #-}
valGamMapTy :: (Ty -> Ty) -> ValGam -> ValGam
valGamMapTy f = gamMapElts (\vgi -> vgi {vgiTy = f (vgiTy vgi)})

{-# LINE 107 "src/ehc/Gam/ValGam.chs" #-}
-- Do something with each ty in a ValGam.
valGamDoWithVarMp :: (HsName -> (Ty,VarMp) -> VarMp -> thr -> (Ty,VarMp,thr)) -> VarMp -> thr -> ValGam -> (ValGam,VarMp,thr)
valGamDoWithVarMp = gamDoTyWithVarMp vgiGetSet

{-# LINE 118 "src/ehc/Gam/ValGam.chs" #-}
valGamTyOfDataCon :: HsName -> ValGam -> (Ty,Ty,ErrL)
valGamTyOfDataCon conNm g
  = (t,rt,e)
  where (t,e) = valGamLookupTy conNm g
        (_,rt) = appUnArr t

{-# LINE 126 "src/ehc/Gam/ValGam.chs" #-}
valGamTyOfDataFld :: HsName -> ValGam -> (Ty,Ty,ErrL)
valGamTyOfDataFld fldNm g
  | null e    = (t,rt,e)
  | otherwise = (t,Ty_Any,e)
  where (t,e) = valGamLookupTy fldNm g
        ((rt:_),_) = appUnArr t


{-# LINE 145 "src/ehc/Gam/ValGam.chs" #-}
instance VarUpdatable ValGamInfo VarMp where
  s `varUpd`  vgi         =   vgi { vgiTy = s `varUpd` vgiTy vgi }
  s `varUpdCyc` vgi         =   substLift vgiTy (\i x -> i {vgiTy = x}) varUpdCyc s vgi

instance VarExtractable ValGamInfo TyVarId where
  varFreeSet vgi         =   varFreeSet (vgiTy vgi)

{-# LINE 156 "src/ehc/Gam/ValGam.chs" #-}
instance PP ValGamInfo where
  pp vgi = ppTy (vgiTy vgi)

{-# LINE 169 "src/ehc/Gam/ValGam.chs" #-}
instance Serialize ValGamInfo where
  sput (ValGamInfo a) = sput a
  sget = liftM ValGamInfo sget