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

{-# LINE 60 "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 75 "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 114 "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

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

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

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