uhc-light-1.1.9.2: 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 Control.Applicative ((<|>))
import UHC.Light.Compiler.VarMp
import UHC.Light.Compiler.Substitutable
import Control.Monad
import UHC.Util.Binary
import UHC.Util.Serialize






{-# LINE 41 "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 60 "src/ehc/Gam/TyKiGam.chs" #-}
deriving instance Typeable TyKiGamInfo

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

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

{-# LINE 73 "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 87 "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 98 "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 109 "src/ehc/Gam/TyKiGam.chs" #-}
tyKiGamLookupByNameErr :: HsName -> TyKiGam -> (TyKiGamInfo,ErrL)
tyKiGamLookupByNameErr n g = tyKiGamLookupErr (appCon n) g

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

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

{-# LINE 124 "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 134 "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 150 "src/ehc/Gam/TyKiGam.chs" #-}
tvarKi :: TyKiGam -> TyKiGam -> VarMp -> VarMp -> TyVarId -> Ty
tvarKi tyKiGam1 tyKiGam2 tvKiVarMp _ tv
  = case tyKiGamLookup tv' tyKiGam1 <|> tyKiGamLookup tv' tyKiGam2 of
      Just tkgi -> tvKiVarMp `varUpd` tkgiKi tkgi
      _         -> tvKiVarMp `varUpd` tv'
  where tv' = {- tyVarMp `varUpd` -} mkTyVar tv

{-# LINE 163 "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 222 "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

type instance ExtrValVarKey TyKiGamInfo = TyVarId

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

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

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