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.Light.Compiler.Base.Debug import UHC.Util.Utils import Control.Monad import UHC.Util.Binary import UHC.Util.Serialize {-# LINE 84 "src/ehc/VarMp.chs" #-} -- moved to package uhc-util {-# LINE 163 "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 206 "src/ehc/VarMp.chs" #-} instToL1VarMp :: [InstTo] -> VarMp instToL1VarMp = varmpIncMetaLev . assocMetaLevTyLToVarMp . instToL1AssocL {-# LINE 215 "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, Data ) {-# LINE 244 "src/ehc/VarMp.chs" #-} vmiMbTy i = case i of {VMITy x -> Just x; _ -> Nothing} {-# LINE 254 "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 260 "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 264 "src/ehc/VarMp.chs" #-} vmiMbPredSeq i = case i of {VMIPredSeq x -> Just x; _ -> Nothing} {-# LINE 278 "src/ehc/VarMp.chs" #-} type VarMp = VarMp' VarId VarMpInfo {-# LINE 287 "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 298 "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 309 "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 351 "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 369 "src/ehc/VarMp.chs" #-} varmpMetaLevTyUnit :: Ord k => MetaLev -> k -> Ty -> VarMp' k VarMpInfo varmpMetaLevTyUnit mlev v t = varmpMetaLevSingleton mlev v (VMITy t) varmpTyUnit :: Ord k => k -> Ty -> VarMp' k VarMpInfo varmpTyUnit = varmpMetaLevTyUnit metaLevVal {-# LINE 382 "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 400 "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 411 "src/ehc/VarMp.chs" #-} varmpPredSeqUnit :: TyVarId -> PredSeq -> VarMp varmpPredSeqUnit v l = mkVarMp (Map.fromList [(v,VMIPredSeq l)]) {-# LINE 416 "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 426 "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 451 "src/ehc/VarMp.chs" #-} varmpTyLookup :: (VarLookup m k VarMpInfo,Ord k) => k -> m -> Maybe Ty varmpTyLookup = varlookupMap vmiMbTy {-# LINE 456 "src/ehc/VarMp.chs" #-} varmpImplsLookup :: VarLookup m ImplsVarId VarMpInfo => ImplsVarId -> m -> Maybe Impls varmpImplsLookup = varlookupMap vmiMbImpls varmpScopeLookup :: VarLookup m TyVarId VarMpInfo => TyVarId -> m -> Maybe PredScope varmpScopeLookup = varlookupMap vmiMbScope varmpPredLookup :: VarLookup m TyVarId VarMpInfo => TyVarId -> m -> Maybe Pred varmpPredLookup = varlookupMap vmiMbPred varmpAssNmLookup :: VarLookup m TyVarId VarMpInfo => TyVarId -> m -> Maybe VarUIDHsName varmpAssNmLookup = varlookupMap vmiMbAssNm {-# LINE 470 "src/ehc/VarMp.chs" #-} varmpLabelLookup :: VarLookup m LabelVarId VarMpInfo => LabelVarId -> m -> Maybe Label varmpLabelLookup = varlookupMap vmiMbLabel varmpOffsetLookup :: VarLookup m UID VarMpInfo => UID -> m -> Maybe LabelOffset varmpOffsetLookup = varlookupMap vmiMbOffset {-# LINE 478 "src/ehc/VarMp.chs" #-} varmpPredSeqLookup :: VarLookup m TyVarId VarMpInfo => TyVarId -> m -> Maybe PredSeq varmpPredSeqLookup = varlookupMap vmiMbPredSeq {-# LINE 487 "src/ehc/VarMp.chs" #-} varmpTyLookupCyc :: VarLookup m TyVarId VarMpInfo => TyVarId -> m -> Maybe Ty varmpTyLookupCyc x m = lookupLiftCycMb2 tyMbVar (flip varmpTyLookup m) x {-# LINE 496 "src/ehc/VarMp.chs" #-} varmpImplsLookupImplsCyc :: VarLookup m ImplsVarId VarMpInfo => Impls -> m -> Maybe Impls varmpImplsLookupImplsCyc x m = lookupLiftCycMb1 implsMbVar (flip varmpImplsLookup m) x varmpImplsLookupCyc :: VarLookup m ImplsVarId VarMpInfo => TyVarId -> m -> Maybe Impls varmpImplsLookupCyc x m = lookupLiftCycMb2 implsMbVar (flip varmpImplsLookup m) x varmpScopeLookupScopeCyc :: VarLookup m ImplsVarId VarMpInfo => PredScope -> m -> Maybe PredScope varmpScopeLookupScopeCyc x m = lookupLiftCycMb1 pscpMbVar (flip varmpScopeLookup m) x varmpAssNmLookupAssNmCyc :: VarLookup m ImplsVarId VarMpInfo => VarUIDHsName -> m -> Maybe VarUIDHsName varmpAssNmLookupAssNmCyc x m = lookupLiftCycMb1 vunmMbVar (flip varmpAssNmLookup m) x {-# LINE 510 "src/ehc/VarMp.chs" #-} varmpLabelLookupLabelCyc :: VarLookup m ImplsVarId VarMpInfo => Label -> m -> Maybe Label varmpLabelLookupLabelCyc x m = lookupLiftCycMb1 labelMbVar (flip varmpLabelLookup m) x varmpLabelLookupCyc :: VarLookup m ImplsVarId VarMpInfo => TyVarId -> m -> Maybe Label varmpLabelLookupCyc x m = lookupLiftCycMb2 labelMbVar (flip varmpLabelLookup m) x {-# LINE 522 "src/ehc/VarMp.chs" #-} varmpTyLookupCyc2 :: VarMp -> TyVarId -> Maybe Ty varmpTyLookupCyc2 x m = varmpTyLookupCyc m x {-# LINE 527 "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 544 "src/ehc/VarMp.chs" #-} varmpLabelLookup2 :: VarMp -> LabelVarId -> Maybe Label varmpLabelLookup2 m v = varmpLabelLookup v m {-# LINE 572 "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 588 "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 610 "src/ehc/VarMp.chs" #-} instance Serialize VarMpInfo where sput (VMITy a) = sputWord8 0 >> sput a sput (VMIImpls a) = sputWord8 1 >> sput a sput (VMIScope a) = sputWord8 2 >> sput a sput (VMIPred a) = sputWord8 3 >> sput a sput (VMIAssNm a) = sputWord8 4 >> sput a sput (VMILabel a) = sputWord8 5 >> sput a sput (VMIOffset a) = sputWord8 6 >> sput a sput (VMIPredSeq a) = sputWord8 7 >> sput a sget = do t <- sgetWord8 case t of 0 -> liftM VMITy sget 1 -> liftM VMIImpls sget 2 -> liftM VMIScope sget 3 -> liftM VMIPred sget 4 -> liftM VMIAssNm sget 5 -> liftM VMILabel sget 6 -> liftM VMIOffset sget 7 -> liftM VMIPredSeq sget