uhc-light-1.1.7.0: src/UHC/Light/Compiler/Gam/TyKiGam.hs

module UHC.Light.Compiler.Gam.TyKiGam
( TyKiGamInfo (..), TyKiGam, emptyTKGI
, tyKiGamLookupByName
, tyKiGamLookup
, tyKiGamLookupErr, tyKiGamLookupKi
, tyKiGamLookupByNameErr
, tyKiGamVarSingleton
, tyKiGamNameSingleton
, tyKiGamSingleton
, tvarKi
, initTyKiGam
, tkgiGetSet
, tyKiGamDoWithVarMp )
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 39 "src/ehc/Gam/TyKiGam.chs" #-}
-- If this changes, also change {%{EH}ConfigInternalVersions}
data TyKiGamInfo
  = TyKiGamInfo
      { tkgiKi :: !Ty }
      deriving Show

emptyTKGI :: TyKiGamInfo
emptyTKGI
  = TyKiGamInfo
      kiStar

type TyKiGam = Gam TyKiKey TyKiGamInfo

{-# LINE 58 "src/ehc/Gam/TyKiGam.chs" #-}
deriving instance Typeable TyKiGamInfo
deriving instance Data TyKiGamInfo

{-# LINE 63 "src/ehc/Gam/TyKiGam.chs" #-}
tkgiGetSet = (tkgiKi,(\x i -> i {tkgiKi = x}))

{-# LINE 67 "src/ehc/Gam/TyKiGam.chs" #-}
tyKiGamLookupByTyVar :: TyVarId -> TyKiGam -> Maybe TyKiGamInfo
tyKiGamLookupByTyVar v g = gamLookup (TyKiKey_TyVar v) g

{-# LINE 72 "src/ehc/Gam/TyKiGam.chs" #-}
tyKiGamLookupByName :: HsName -> TyKiGam -> Maybe TyKiGamInfo
tyKiGamLookupByName n g
  = case gamLookup (TyKiKey_Name n) g of
      Nothing
        | hsnIsProd n
            -> Just (TyKiGamInfo (replicate (hsnProdArity n) kiStar `appArr` kiStar))
      x     -> x

{-# LINE 86 "src/ehc/Gam/TyKiGam.chs" #-}
tyKiGamLookup :: Ty -> TyKiGam -> Maybe TyKiGamInfo
tyKiGamLookup t g
  = case tyMbVar t of
      Just v  -> tyKiGamLookupByTyVar v g
      Nothing ->
                 case tyMbCon t of
                   Just n -> tyKiGamLookupByName n g
                   _      -> Nothing

{-# LINE 97 "src/ehc/Gam/TyKiGam.chs" #-}
tyKiGamLookupErr :: Ty -> TyKiGam -> (TyKiGamInfo,ErrL)
tyKiGamLookupErr t g
  = case tyKiGamLookup t g of
      Nothing -> (emptyTKGI,[rngLift emptyRange mkErr_NamesNotIntrod "kind" [mkHNm $ show t]])
      Just i  -> (i,[])

tyKiGamLookupKi :: TyKiGam -> Ty -> Ty
tyKiGamLookupKi g t = tkgiKi $ fst $ tyKiGamLookupErr t g

{-# LINE 108 "src/ehc/Gam/TyKiGam.chs" #-}
tyKiGamLookupByNameErr :: HsName -> TyKiGam -> (TyKiGamInfo,ErrL)
tyKiGamLookupByNameErr n g = tyKiGamLookupErr (appCon n) g

{-# LINE 113 "src/ehc/Gam/TyKiGam.chs" #-}
tyKiGamVarSingleton :: TyVarId -> TyKiGamInfo -> TyKiGam
tyKiGamVarSingleton v k = gamSingleton (TyKiKey_TyVar v) k

{-# LINE 118 "src/ehc/Gam/TyKiGam.chs" #-}
tyKiGamNameSingleton :: HsName -> TyKiGamInfo -> TyKiGam
tyKiGamNameSingleton n k = gamSingleton (TyKiKey_Name n) k

{-# LINE 123 "src/ehc/Gam/TyKiGam.chs" #-}
tyKiGamSingleton :: Ty -> TyKiGamInfo -> TyKiGam
tyKiGamSingleton t k
  = case tyMbVar t of
      Just v  -> tyKiGamVarSingleton v k
      Nothing -> case tyMbCon t of
                   Just n -> tyKiGamNameSingleton n k
                   _      -> panic "Gam.tyKiGamSingleton"

{-# LINE 133 "src/ehc/Gam/TyKiGam.chs" #-}
-- Do something with each kind in a TyKiGam.
tyKiGamDoWithVarMp :: (TyKiKey -> (Ty,VarMp) -> VarMp -> thr -> (Ty,VarMp,thr)) -> VarMp -> thr -> TyKiGam -> (TyKiGam,VarMp,thr)
tyKiGamDoWithVarMp = gamDoTyWithVarMp tkgiGetSet

{-# LINE 149 "src/ehc/Gam/TyKiGam.chs" #-}
tvarKi :: TyKiGam -> VarMp -> VarMp -> TyVarId -> Ty
tvarKi tyKiGam tvKiVarMp _ tv
  = case tyKiGamLookup tv' tyKiGam of
      Just tkgi -> tvKiVarMp `varUpd` tkgiKi tkgi
      _         -> tvKiVarMp `varUpd` tv'
  where tv' = {- tyVarMp `varUpd` -} mkTyVar tv

{-# LINE 162 "src/ehc/Gam/TyKiGam.chs" #-}
initTyKiGam :: TyKiGam
initTyKiGam
  = gamUnions
      [ (tyKiGamNameSingleton hsnArrow      (TyKiGamInfo ([kiStar,kiStar] `appArr` kiStar)))
      , gamUnions
          (zipWith tyKiGamNameSingleton
               [ hsnInt, hsnChar
               , hsnInteger
               ]
               (repeat star)
          )
      , (tyKiGamNameSingleton hsnRow        (TyKiGamInfo kiRow))
      , (tyKiGamNameSingleton hsnRec        (TyKiGamInfo ([kiRow] `appArr` kiStar)))
      , (tyKiGamNameSingleton hsnSum        (TyKiGamInfo ([kiRow] `appArr` kiStar)))
      , (tyKiGamNameSingleton hsnPrArrow    (TyKiGamInfo ([kiStar,kiStar] `appArr` kiStar)))
      , (tyKiGamNameSingleton hsnEqTilde    (TyKiGamInfo ([kiStar,kiStar] `appArr` kiStar)))	-- TBD: should be polykinded, but does not matter as already rewritten to explicit equality predicate at the time this info is used
      ]
  where star = TyKiGamInfo kiStar

{-# LINE 221 "src/ehc/Gam/TyKiGam.chs" #-}
instance VarUpdatable TyKiGamInfo VarMp where
  s `varUpd`  tkgi         =   tkgi { tkgiKi = s `varUpd` tkgiKi tkgi }
  s `varUpdCyc` tkgi         =   substLift tkgiKi (\i x -> i {tkgiKi = x}) varUpdCyc s tkgi

instance VarExtractable TyKiGamInfo TyVarId where
  varFreeSet tkgi         =   varFreeSet (tkgiKi tkgi)

{-# LINE 230 "src/ehc/Gam/TyKiGam.chs" #-}
instance PP TyKiGamInfo where
  pp i = ppTy (tkgiKi i)

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