PolGam.hs

module UHC.Light.Compiler.Gam.PolGam
( PolGamInfo (..), PolGam, mapPolGam, mkPGI
, polGamLookup, polGamLookupErr
, initPolGam )
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 Control.Monad
import UHC.Util.Binary
import UHC.Util.Serialize






{-# LINE 37 "src/ehc/Gam/PolGam.chs" #-}
-- If this changes, also change {%{EH}ConfigInternalVersions}
data PolGamInfo = PolGamInfo { pgiPol :: Polarity } deriving Show

mkPGI :: Ty -> PolGamInfo
mkPGI t = PolGamInfo t

emptyPGI :: PolGamInfo
emptyPGI = mkPGI Ty_Any

type PolGam = Gam HsName PolGamInfo


mapPolGam :: (Ty -> Ty) -> PolGam -> PolGam
mapPolGam f
  = fst . gamMapThr (\(nm, PolGamInfo ty) thr -> ((nm, PolGamInfo $ f ty), thr)) ()

{-# LINE 55 "src/ehc/Gam/PolGam.chs" #-}
deriving instance Typeable PolGamInfo

{-# LINE 59 "src/ehc/Gam/PolGam.chs" #-}
polGamLookup :: HsName -> PolGam -> Maybe PolGamInfo
polGamLookup = gamLookup

polGamLookupErr :: HsName -> PolGam -> (PolGamInfo,ErrL)
polGamLookupErr n g
  = case polGamLookup n g of
      Nothing  -> (emptyPGI,[rngLift emptyRange mkErr_NamesNotIntrod "polarity" [n]])
      Just i   -> (i,[])

{-# LINE 74 "src/ehc/Gam/PolGam.chs" #-}
initPolGam :: PolGam
initPolGam
  = assocLToGam
      [ (hsnArrow       	, mkPGI $ quant $ [mkPolNegate var, var] `appArr` var)
      , (hsnInt         	, mkPGI   quantvar)
      , (hsnChar        	, mkPGI   quantvar)
      , (hsnRec         	, mkPGI $ quant $ [var] `appArr` var)
      , (hsnInteger     	, mkPGI quantvar)
      , (hsnInt8Unboxed  	, mkPGI quantvar)
      , (hsnInt16Unboxed  	, mkPGI quantvar)
      , (hsnInt32Unboxed  	, mkPGI quantvar)
      , (hsnInt64Unboxed  	, mkPGI quantvar)
      , (hsnWordUnboxed  	, mkPGI quantvar)
      , (hsnWord8Unboxed  	, mkPGI quantvar)
      , (hsnWord16Unboxed  	, mkPGI quantvar)
      , (hsnWord32Unboxed  	, mkPGI quantvar)
      , (hsnWord64Unboxed  	, mkPGI quantvar)
      , (hsnAddrUnboxed  	, mkPGI quantvar)
      ]
  where
    u     = uidStart
    quant = mkTyQu tyQu_Forall [(u,kiStar)]	-- TBD
    var   = mkPolVar u
    quantvar = quant var

{-# LINE 113 "src/ehc/Gam/PolGam.chs" #-}
instance VarUpdatable PolGamInfo VarMp where
  s `varUpd` pgi  = pgi { pgiPol = s `varUpd` pgiPol pgi }
  s `varUpdCyc` pgi = substLift pgiPol (\i x -> i {pgiPol = x}) varUpdCyc s pgi

type instance ExtrValVarKey PolGamInfo = TyVarId

instance VarExtractable PolGamInfo where
  varFreeSet pgi = varFreeSet (pgiPol pgi)

{-# LINE 124 "src/ehc/Gam/PolGam.chs" #-}
instance PP PolGamInfo where
  pp i = ppTy (pgiPol i)

{-# LINE 137 "src/ehc/Gam/PolGam.chs" #-}
instance Serialize PolGamInfo where
  sput (PolGamInfo a) = sput a
  sget = liftM PolGamInfo sget