uhc-light-1.1.9.4: src/UHC/Light/Compiler/VarMp.hs

module UHC.Light.Compiler.VarMp
( vmiMbTy
, tyAsVarMp', tyAsVarMp
, varmpTyLookupCyc
, varmpTyLookupCyc2
, module UHC.Util.VarMp
, module UHC.Light.Compiler.VarLookup
, assocMetaLevTyLToVarMp, assocTyLToVarMp, varmpToAssocTyL
, instToL1VarMp
, VarMpInfo (..)
, VarMp
, varmpFilterTy
, varmpMetaLevTyUnit, varmpTyUnit
, tyRestrictKiVarMp
, varmpTyLookup
, vmiMbImpls, vmiMbScope, vmiMbPred, vmiMbAssNm
, varmpTailAddOcc
, varmpMapThr, varmpMapThrTy
, varmpImplsUnit, assocImplsLToVarMp, varmpScopeUnit, varmpPredUnit, varmpAssNmUnit
, varmpImplsLookup, varmpScopeLookup, varmpPredLookup
, varmpImplsLookupImplsCyc, varmpImplsLookupCyc, varmpScopeLookupScopeCyc, varmpAssNmLookupAssNmCyc
, varmpPredLookup2, varmpScopeLookup2, varmpAssNmLookup2, varmpImplsLookupCyc2
, vmiMbLabel, vmiMbOffset
, varmpLabelUnit, varmpOffsetUnit
, varmpLabelLookup, varmpOffsetLookup
, varmpLabelLookupCyc, varmpLabelLookupLabelCyc
, vmiMbPredSeq
, varmpPredSeqUnit
, varmpPredSeqLookup
, varmpinfoMkVar
, ppVarMpInfoCfgTy, ppVarMpInfoDt )
where
import Data.List
import UHC.Light.Compiler.Base.Common
import UHC.Light.Compiler.Ty
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.Maybe
import UHC.Util.Pretty
import UHC.Light.Compiler.Ty.Pretty
import UHC.Light.Compiler.Error
import UHC.Util.VarMp
import UHC.Light.Compiler.VarLookup
import UHC.Util.Utils
import Control.Monad
import UHC.Util.Binary
import UHC.Util.Serialize







{-# LINE 78 "src/ehc/VarMp.chs" #-}
-- moved to package uhc-util


{-# LINE 157 "src/ehc/VarMp.chs" #-}
assocMetaLevTyLToVarMp :: Ord k => AssocL k (MetaLev,Ty) -> VarMp' k VarMpInfo
assocMetaLevTyLToVarMp = assocMetaLevLToVarMp . assocLMapElt (\(ml,t) -> (ml, VMITy t)) -- varmpUnions [ varmpMetaLevTyUnit lev v t | (v,(lev,t)) <- l ]

assocTyLToVarMp :: Ord k => AssocL k Ty -> VarMp' k VarMpInfo
assocTyLToVarMp = assocLToVarMp . assocLMapElt VMITy

varmpToAssocTyL :: VarMp' k VarMpInfo -> AssocL k Ty
varmpToAssocTyL c = [ (v,t) | (v,VMITy t) <- varmpToAssocL c ]


{-# LINE 200 "src/ehc/VarMp.chs" #-}
instToL1VarMp :: [InstTo] -> VarMp
instToL1VarMp = varmpIncMetaLev . assocMetaLevTyLToVarMp . instToL1AssocL

{-# LINE 209 "src/ehc/VarMp.chs" #-}
data VarMpInfo
  = VMITy      !Ty
  | VMIImpls   !Impls
  | VMIScope   !PredScope
  | VMIPred    !Pred
  | VMIAssNm   !VarUIDHsName
  | VMILabel   !Label
  | VMIOffset  !LabelOffset
--  | VMIExts    !RowExts
  | VMIPredSeq !PredSeq
  deriving
    ( Eq, Ord, Show
    , Typeable, Generic
    )

{-# LINE 238 "src/ehc/VarMp.chs" #-}
vmiMbTy      i = case i of {VMITy      x -> Just x; _ -> Nothing}

{-# LINE 248 "src/ehc/VarMp.chs" #-}
vmiMbImpls   i = case i of {VMIImpls   x -> Just x; _ -> Nothing}
vmiMbScope   i = case i of {VMIScope   x -> Just x; _ -> Nothing}
vmiMbPred    i = case i of {VMIPred    x -> Just x; _ -> Nothing}
vmiMbAssNm   i = case i of {VMIAssNm   x -> Just x; _ -> Nothing}
{-# LINE 254 "src/ehc/VarMp.chs" #-}
vmiMbLabel   i = case i of {VMILabel   x -> Just x; _ -> Nothing}
vmiMbOffset  i = case i of {VMIOffset  x -> Just x; _ -> Nothing}
{-# LINE 258 "src/ehc/VarMp.chs" #-}
vmiMbPredSeq i = case i of {VMIPredSeq x -> Just x; _ -> Nothing}

{-# LINE 272 "src/ehc/VarMp.chs" #-}
type VarMp  = VarMp' VarId VarMpInfo

{-# LINE 281 "src/ehc/VarMp.chs" #-}
varmpFilterTy :: Ord k => (k -> Ty -> Bool) -> VarMp' k VarMpInfo -> VarMp' k VarMpInfo
varmpFilterTy f
  = varmpFilter
        (\v i -> case i of {VMITy t -> f v t ; _ -> True})

{-# LINE 292 "src/ehc/VarMp.chs" #-}
varmpTailAddOcc :: ImplsProveOcc -> Impls -> (Impls,VarMp)
varmpTailAddOcc o (Impls_Tail i os) = (t, varmpImplsUnit i t)
                                    where t = Impls_Tail i (o:os)
varmpTailAddOcc _ x                 = (x,emptyVarMp)

{-# LINE 303 "src/ehc/VarMp.chs" #-}
varmpMapThr :: (MetaLev -> TyVarId -> VarMpInfo -> thr -> (VarMpInfo,thr)) -> thr -> VarMp -> (VarMp,thr)
varmpMapThr f thr (VarMp l ms)
  = (VarMp l ms',thr')
  where (ms',thr') = foldMlev thr ms
        foldMp mlev thr fm
          = Map.foldrWithKey
              (\v i (fm,thr)
                 -> let  (i',thr') = f mlev v i thr
                    in   (Map.insert v i' fm,thr')
              )
              (Map.empty,thr) fm
        foldMlev thr ms
          = foldr
              (\(mlev,m) (ms,thr)
                -> let (m',thr') = foldMp mlev thr m
                   in  (m':ms,thr')
              )
              ([],thr) (zip [0..] ms)

varmpMapThrTy :: (MetaLev -> TyVarId -> Ty -> thr -> (Ty,thr)) -> thr -> VarMp -> (VarMp,thr)
varmpMapThrTy f
  = varmpMapThr
      (\mlev v i thr
         -> case i of
              VMITy t -> (VMITy t,thr')
                      where (t',thr') = f mlev v t thr
              _       -> (i,thr)
      )

{-# LINE 345 "src/ehc/VarMp.chs" #-}
varmpinfoMkVar :: TyVarId -> VarMpInfo -> Ty
varmpinfoMkVar v i
  = case i of
      VMITy       t -> mkTyVar v
      VMIImpls    i -> mkImplsVar v
      _             -> mkTyVar v					-- rest incomplete

{-# LINE 363 "src/ehc/VarMp.chs" #-}
varmpMetaLevTyUnit :: Ord k => MetaLev -> k -> Ty -> VarMp' k VarMpInfo
varmpMetaLevTyUnit mlev v t = varlookupSingletonWithMetaLev mlev v (VMITy t)

varmpTyUnit :: Ord k => k -> Ty -> VarMp' k VarMpInfo
varmpTyUnit = varmpMetaLevTyUnit metaLevVal

{-# LINE 371 "src/ehc/VarMp.chs" #-}
varmpImplsUnit :: ImplsVarId -> Impls -> VarMp
varmpImplsUnit v i = mkVarMp (Map.fromList [(v,VMIImpls i)])

varmpScopeUnit :: TyVarId -> PredScope -> VarMp
varmpScopeUnit v sc = mkVarMp (Map.fromList [(v,VMIScope sc)])

varmpPredUnit :: TyVarId -> Pred -> VarMp
varmpPredUnit v p = mkVarMp (Map.fromList [(v,VMIPred p)])

varmpAssNmUnit :: TyVarId -> VarUIDHsName -> VarMp
varmpAssNmUnit v p = mkVarMp (Map.fromList [(v,VMIAssNm p)])

assocImplsLToVarMp :: AssocL ImplsVarId Impls -> VarMp
assocImplsLToVarMp = mkVarMp . Map.fromList . assocLMapElt VMIImpls

{-# LINE 389 "src/ehc/VarMp.chs" #-}
varmpLabelUnit :: LabelVarId -> Label -> VarMp
varmpLabelUnit v l = mkVarMp (Map.fromList [(v,VMILabel l)])

varmpOffsetUnit :: UID -> LabelOffset -> VarMp
varmpOffsetUnit v l = mkVarMp (Map.fromList [(v,VMIOffset l)])


{-# LINE 400 "src/ehc/VarMp.chs" #-}
varmpPredSeqUnit :: TyVarId -> PredSeq -> VarMp
varmpPredSeqUnit v l = mkVarMp (Map.fromList [(v,VMIPredSeq l)])

{-# LINE 405 "src/ehc/VarMp.chs" #-}
-- restrict the kinds of tvars bound to value identifiers to kind *
tyRestrictKiVarMp :: [Ty] -> VarMp
tyRestrictKiVarMp ts = varmpIncMetaLev $ assocTyLToVarMp [ (v,kiStar) | t <- ts, v <- maybeToList $ tyMbVar t ]

{-# LINE 415 "src/ehc/VarMp.chs" #-}
-- | Encode 'ty' as a tvar + VarMp, with additional initial construction
tyAsVarMp' :: (UID -> Ty -> Ty) -> UID -> Ty -> (Ty,VarMp)
tyAsVarMp' f u t
  = case f v1 t of
      t | tyIsVar t -> (t, emptyVarMp)
        | otherwise -> (mkTyVar v2, varmpTyUnit v2 t)
  where [v1,v2] = mkNewLevUIDL 2 u

-- | Encode 'ty' as a tvar + VarMp
tyAsVarMp :: UID -> Ty -> (Ty,VarMp)
tyAsVarMp = tyAsVarMp' (flip const)

{-# LINE 440 "src/ehc/VarMp.chs" #-}
varmpTyLookup :: (VarLookup m, Ord (VarLookupKey m), VarLookupVal m ~ VarMpInfo) => VarLookupKey m -> m -> Maybe Ty
varmpTyLookup = varlookupMap vmiMbTy

{-# LINE 445 "src/ehc/VarMp.chs" #-}
varmpImplsLookup :: (VarLookup m, VarLookupVal m ~ VarMpInfo, VarLookupKey m ~ ImplsVarId) => ImplsVarId -> m -> Maybe Impls
varmpImplsLookup = varlookupMap vmiMbImpls

varmpScopeLookup :: (VarLookup m, VarLookupVal m ~ VarMpInfo, VarLookupKey m ~ TyVarId) => TyVarId -> m -> Maybe PredScope
varmpScopeLookup = varlookupMap vmiMbScope

varmpPredLookup :: (VarLookup m, VarLookupVal m ~ VarMpInfo, VarLookupKey m ~ TyVarId) => TyVarId -> m -> Maybe Pred
varmpPredLookup = varlookupMap vmiMbPred

varmpAssNmLookup :: (VarLookup m, VarLookupVal m ~ VarMpInfo, VarLookupKey m ~ TyVarId) => TyVarId -> m -> Maybe VarUIDHsName
varmpAssNmLookup = varlookupMap vmiMbAssNm

{-# LINE 459 "src/ehc/VarMp.chs" #-}
varmpLabelLookup :: (VarLookup m, VarLookupVal m ~ VarMpInfo, VarLookupKey m ~ LabelVarId) => LabelVarId -> m -> Maybe Label
varmpLabelLookup = varlookupMap vmiMbLabel

varmpOffsetLookup :: (VarLookup m, VarLookupVal m ~ VarMpInfo, VarLookupKey m ~ UID) => UID -> m -> Maybe LabelOffset
varmpOffsetLookup = varlookupMap vmiMbOffset

{-# LINE 467 "src/ehc/VarMp.chs" #-}
varmpPredSeqLookup :: (VarLookup m, VarLookupVal m ~ VarMpInfo, VarLookupKey m ~ TyVarId) => TyVarId -> m -> Maybe PredSeq
varmpPredSeqLookup = varlookupMap vmiMbPredSeq

{-# LINE 476 "src/ehc/VarMp.chs" #-}
varmpTyLookupCyc :: (VarLookup m, VarLookupVal m ~ VarMpInfo, VarLookupKey m ~ TyVarId) => TyVarId -> m -> Maybe Ty
varmpTyLookupCyc x m = lookupLiftCycMb2 tyMbVar (flip varmpTyLookup m) x

{-# LINE 485 "src/ehc/VarMp.chs" #-}
varmpImplsLookupImplsCyc :: (VarLookup m, VarLookupVal m ~ VarMpInfo, VarLookupKey m ~ ImplsVarId) => Impls -> m -> Maybe Impls
varmpImplsLookupImplsCyc x m = lookupLiftCycMb1 implsMbVar (flip varmpImplsLookup m) x

varmpImplsLookupCyc :: (VarLookup m, VarLookupVal m ~ VarMpInfo, VarLookupKey m ~ ImplsVarId) => TyVarId -> m -> Maybe Impls
varmpImplsLookupCyc x m = lookupLiftCycMb2 implsMbVar (flip varmpImplsLookup m) x

varmpScopeLookupScopeCyc :: (VarLookup m, VarLookupVal m ~ VarMpInfo, VarLookupKey m ~ ImplsVarId) => PredScope -> m -> Maybe PredScope
varmpScopeLookupScopeCyc x m = lookupLiftCycMb1 pscpMbVar (flip varmpScopeLookup m) x

varmpAssNmLookupAssNmCyc :: (VarLookup m, VarLookupVal m ~ VarMpInfo, VarLookupKey m ~ ImplsVarId) => VarUIDHsName -> m -> Maybe VarUIDHsName
varmpAssNmLookupAssNmCyc x m = lookupLiftCycMb1 vunmMbVar (flip varmpAssNmLookup m) x

{-# LINE 499 "src/ehc/VarMp.chs" #-}
varmpLabelLookupLabelCyc :: (VarLookup m, VarLookupVal m ~ VarMpInfo, VarLookupKey m ~ ImplsVarId) => Label -> m -> Maybe Label
varmpLabelLookupLabelCyc x m = lookupLiftCycMb1 labelMbVar (flip varmpLabelLookup m) x

varmpLabelLookupCyc :: (VarLookup m, VarLookupVal m ~ VarMpInfo, VarLookupKey m ~ ImplsVarId) => TyVarId -> m -> Maybe Label
varmpLabelLookupCyc x m = lookupLiftCycMb2 labelMbVar (flip varmpLabelLookup m) x

{-# LINE 511 "src/ehc/VarMp.chs" #-}
varmpTyLookupCyc2 :: VarMp -> TyVarId -> Maybe Ty
varmpTyLookupCyc2 x m = varmpTyLookupCyc m x

{-# LINE 516 "src/ehc/VarMp.chs" #-}
varmpScopeLookup2 :: VarMp -> TyVarId -> Maybe PredScope
varmpScopeLookup2 m v = varmpScopeLookup v m

varmpImplsLookup2 :: VarMp -> ImplsVarId -> Maybe Impls
varmpImplsLookup2 m v = varmpImplsLookup v m

varmpImplsLookupCyc2 :: VarMp -> ImplsVarId -> Maybe Impls
varmpImplsLookupCyc2 m v = varmpImplsLookupCyc v m

varmpPredLookup2 :: VarMp -> TyVarId -> Maybe Pred
varmpPredLookup2 m v = varmpPredLookup v m

varmpAssNmLookup2 :: VarMp -> TyVarId -> Maybe VarUIDHsName
varmpAssNmLookup2 m v = varmpAssNmLookup v m

{-# LINE 533 "src/ehc/VarMp.chs" #-}
varmpLabelLookup2 :: VarMp -> LabelVarId -> Maybe Label
varmpLabelLookup2 m v = varmpLabelLookup v m


{-# LINE 561 "src/ehc/VarMp.chs" #-}
ppVarMpInfoCfgTy :: CfgPPTy -> VarMpInfo -> PP_Doc
ppVarMpInfoCfgTy c i
  = case i of
      VMITy       t -> ppTyWithCfg    c t
      VMIImpls    i -> ppImplsWithCfg c i
      VMIScope    s -> pp s						-- rest incomplete
      VMIPred     p -> pp p
      VMILabel    x -> pp x
      VMIOffset   x -> pp x
      VMIPredSeq  x -> pp "predseq" -- pp x

ppVarMpInfoDt :: VarMpInfo -> PP_Doc
ppVarMpInfoDt = ppVarMpInfoCfgTy cfgPPTyDT

{-# LINE 577 "src/ehc/VarMp.chs" #-}
instance PP VarMpInfo where
  pp (VMITy       t) = pp t
  pp (VMIImpls    i) = pp i
  pp (VMIScope    s) = pp s
  pp (VMIPred     p) = pp p
  pp (VMILabel    x) = pp x
  pp (VMIOffset   x) = pp x
  -- pp (VMIExts     x) = pp "exts" -- pp x
  pp (VMIPredSeq  x) = pp "predseq" -- pp x

{-# LINE 599 "src/ehc/VarMp.chs" #-}
instance Serialize VarMpInfo