module UHC.Light.Compiler.CHR.CtxtRedOnly.Instances ( module UHC.Light.Compiler.CHR.CtxtRedOnly.Constraint, module UHC.Light.Compiler.CHR.CtxtRedOnly.Guard ) where import UHC.Util.CHR import UHC.Light.Compiler.CHR.CtxtRedOnly.Key import UHC.Light.Compiler.CHR.CtxtRedOnly.Constraint import UHC.Light.Compiler.CHR.CtxtRedOnly.Guard import qualified Data.Map as Map import qualified Data.Set as Set import Data.Maybe import UHC.Util.Pretty import UHC.Util.AGraph import UHC.Light.Compiler.Base.Common import UHC.Light.Compiler.Base.TermLike import UHC.Light.Compiler.Ty import UHC.Light.Compiler.VarMp import UHC.Light.Compiler.Substitutable import UHC.Light.Compiler.Ty.FitsInCommon2 import UHC.Light.Compiler.Ty.FitsIn import UHC.Light.Compiler.Ty.TreeTrieKey import UHC.Light.Compiler.Base.HsName.Builtin import Control.Monad import UHC.Util.Binary import UHC.Util.Serialize {-# LINE 42 "src/ehc/CHR/CtxtRedOnly/Instances.chs" #-} type instance ExtrValVarKey ConstraintToInfoMap = TyVarId instance VarExtractable ConstraintToInfoMap where varFreeSet x = Set.unions [ varFreeSet k | k <- Map.keys x ] instance VarUpdatable ConstraintToInfoMap VarMp where varUpd s x = Map.mapKeysWith (++) (varUpd s) x type instance ExtrValVarKey Guard = TyVarId instance VarExtractable Guard where varFreeSet (HasStrictCommonScope p1 p2 p3) = Set.unions $ map varFreeSet [p1,p2,p3] varFreeSet (IsStrictParentScope p1 p2 p3) = Set.unions $ map varFreeSet [p1,p2,p3] varFreeSet (IsVisibleInScope p1 p2 ) = Set.unions $ map varFreeSet [p1,p2] varFreeSet (NotEqualScope p1 p2 ) = Set.unions $ map varFreeSet [p1,p2] varFreeSet (EqualScope p1 p2 ) = Set.unions $ map varFreeSet [p1,p2] varFreeSet (NonEmptyRowLacksLabel r o t l ) = Set.unions [varFreeSet r,varFreeSet o,varFreeSet t,varFreeSet l] instance VarUpdatable Guard VarMp where varUpd s (HasStrictCommonScope p1 p2 p3) = HasStrictCommonScope (s `varUpd` p1) (s `varUpd` p2) (s `varUpd` p3) varUpd s (IsStrictParentScope p1 p2 p3) = IsStrictParentScope (s `varUpd` p1) (s `varUpd` p2) (s `varUpd` p3) varUpd s (IsVisibleInScope p1 p2 ) = IsVisibleInScope (s `varUpd` p1) (s `varUpd` p2) varUpd s (NotEqualScope p1 p2 ) = NotEqualScope (s `varUpd` p1) (s `varUpd` p2) varUpd s (EqualScope p1 p2 ) = EqualScope (s `varUpd` p1) (s `varUpd` p2) varUpd s (NonEmptyRowLacksLabel r o t l ) = NonEmptyRowLacksLabel (s `varUpd` r) (s `varUpd` o) (s `varUpd` t) (s `varUpd` l) {-# LINE 85 "src/ehc/CHR/CtxtRedOnly/Instances.chs" #-} type instance ExtrValVarKey VarUIDHsName = TyVarId instance VarExtractable VarUIDHsName where varFreeSet (VarUIDHs_Var i) = Set.singleton i varFreeSet _ = Set.empty -- instance VarUpdatable VarUIDHsName VarMp where instance (VarLookup m, VarLookupKey m ~ ImplsVarId, VarLookupVal m ~ VarMpInfo) => VarUpdatable VarUIDHsName m where varUpd s a = maybe a id $ varmpAssNmLookupAssNmCyc a s {-# LINE 97 "src/ehc/CHR/CtxtRedOnly/Instances.chs" #-} type instance ExtrValVarKey RedHowAnnotation = TyVarId instance VarExtractable RedHowAnnotation where varFreeSet (RedHow_Assumption vun sc) = Set.unions [varFreeSet vun,varFreeSet sc] varFreeSet (RedHow_ByLabel l o sc) = Set.unions [varFreeSet l,varFreeSet o,varFreeSet sc] varFreeSet _ = Set.empty instance VarUpdatable RedHowAnnotation VarMp where varUpd s (RedHow_Assumption vun sc) = RedHow_Assumption (varUpd s vun) (varUpd s sc) varUpd s (RedHow_ByLabel l o sc) = RedHow_ByLabel (varUpd s l) (varUpd s o) (varUpd s sc) varUpd _ x = x {-# LINE 122 "src/ehc/CHR/CtxtRedOnly/Instances.chs" #-} instance CHREmptySubstitution VarMp where chrEmptySubst = emptyVarMp {-# LINE 132 "src/ehc/CHR/CtxtRedOnly/Instances.chs" #-} instance CHRMatchable FIIn Pred VarMp where chrMatchTo fi subst pr1 pr2 = do { (_,subst') <- fitPredIntoPred (fi {fiVarMp = subst |+> fiVarMp fi}) pr1 pr2 ; return subst' } {-# LINE 140 "src/ehc/CHR/CtxtRedOnly/Instances.chs" #-} instance CHRMatchable FIIn CHRPredOccCxt VarMp where chrMatchTo e subst (CHRPredOccCxt_Scope1 sc1) (CHRPredOccCxt_Scope1 sc2) = chrMatchTo e subst sc1 sc2 instance CHRMatchable FIIn PredScope VarMp where chrMatchTo _ subst (PredScope_Var v1) sc2@(PredScope_Var v2) | v1 == v2 = Just emptyVarMp chrMatchTo e subst (PredScope_Var v1) sc2 | isJust mbSc = chrMatchTo e subst (fromJust mbSc) sc2 where mbSc = varmpScopeLookup v1 subst chrMatchTo e subst sc1 (PredScope_Var v2) | isJust mbSc = chrMatchTo e subst sc1 (fromJust mbSc) where mbSc = varmpScopeLookup v2 subst chrMatchTo _ subst _ (PredScope_Var v2) = Nothing chrMatchTo _ subst (PredScope_Var v1) sc2 = Just $ v1 `varmpScopeUnit` sc2 chrMatchTo _ subst (PredScope_Lev l1) (PredScope_Lev l2) | l1 == l2 = Just emptyVarMp chrMatchTo _ subst _ _ = Nothing {-# LINE 156 "src/ehc/CHR/CtxtRedOnly/Instances.chs" #-} instance CHRMatchable FIIn CHRPredOcc VarMp where chrMatchTo fi subst po1 po2 = do { subst1 <- chrMatchTo fi subst (cpoPr po1) (cpoPr po2) ; subst2 <- chrMatchTo fi subst (cpoCxt po1) (cpoCxt po2) ; return $ subst2 |+> subst1 } {-# LINE 165 "src/ehc/CHR/CtxtRedOnly/Instances.chs" #-} instance CHRMatchable FIIn Label VarMp where chrMatchTo _ subst (Label_Var v1) lb2@(Label_Var v2) | v1 == v2 = Just emptyVarMp chrMatchTo e subst (Label_Var v1) lb2 | isJust mbLb = chrMatchTo e subst (fromJust mbLb) lb2 where mbLb = varmpLabelLookup v1 subst chrMatchTo e subst lb1 (Label_Var v2) | isJust mbLb = chrMatchTo e subst lb1 (fromJust mbLb) where mbLb = varmpLabelLookup v2 subst chrMatchTo _ subst _ (Label_Var v2) = Nothing chrMatchTo _ subst (Label_Var v1) lb2 = Just $ v1 `varmpLabelUnit` lb2 chrMatchTo _ subst (Label_Lab l1) (Label_Lab l2) | l1 == l2 = Just emptyVarMp chrMatchTo _ subst _ _ = Nothing {-# LINE 178 "src/ehc/CHR/CtxtRedOnly/Instances.chs" #-} instance CHRMatchable FIIn LabelOffset VarMp where chrMatchTo _ subst (LabelOffset_Var v1) of2@(LabelOffset_Var v2) | v1 == v2 = Just emptyVarMp chrMatchTo s subst (LabelOffset_Var v1) of2 | isJust mbOf = chrMatchTo s subst (fromJust mbOf) of2 where mbOf = varmpOffsetLookup v1 subst chrMatchTo s subst of1 (LabelOffset_Var v2) | isJust mbOf = chrMatchTo s subst of1 (fromJust mbOf) where mbOf = varmpOffsetLookup v2 subst chrMatchTo _ subst _ (LabelOffset_Var v2) = Nothing chrMatchTo _ subst (LabelOffset_Var v1) of2 = Just $ v1 `varmpOffsetUnit` of2 chrMatchTo _ subst (LabelOffset_Off l1) (LabelOffset_Off l2) | l1 == l2 = Just emptyVarMp chrMatchTo _ subst _ _ = Nothing {-# LINE 195 "src/ehc/CHR/CtxtRedOnly/Instances.chs" #-} instance CHRCheckable FIIn Guard VarMp where chrCheck env subst x = chk x where subst' = subst |+> fiVarMp env chk (HasStrictCommonScope (PredScope_Var vDst) sc1 sc2) = do { let sc1' = varUpd subst' sc1 sc2' = varUpd subst' sc2 ; scDst <- pscpCommon sc1' sc2' ; if scDst == sc1' then Nothing else return $ vDst `varmpScopeUnit` scDst } chk (IsStrictParentScope (PredScope_Var vDst) sc1 sc2) = do { let sc1' = varUpd subst' sc1 sc2' = varUpd subst' sc2 ; scDst <- pscpCommon sc1' sc2' ; if scDst == sc1' && sc1' /= sc2' then return $ vDst `varmpScopeUnit` scDst else Nothing } chk (NotEqualScope sc1 sc2) | isJust c = if fromJust c /= EQ then return emptyVarMp else Nothing where c = pscpCmp (varUpd subst' sc1) (varUpd subst' sc2) chk (EqualScope sc1 sc2) | isJust c = if fromJust c == EQ then return emptyVarMp else Nothing where c = pscpCmp (varUpd subst' sc1) (varUpd subst' sc2) chk (IsVisibleInScope scDst@(PredScope_Var vDst) sc1) | isJust mbSc = chk (IsVisibleInScope (fromJust mbSc) sc1) where mbSc = varmpScopeLookupScopeCyc scDst subst' chk (IsVisibleInScope (PredScope_Var vDst) sc1) = return $ vDst `varmpScopeUnit` sc1 chk (IsVisibleInScope scDst sc1) | pscpIsVisibleIn (varUpd subst' scDst) (varUpd subst' sc1) = return emptyVarMp chk (NonEmptyRowLacksLabel r1@(Ty_Var tv _) (LabelOffset_Var vDst) ty lab) | fiAllowTyVarBind env r1 && not (null exts) && presence == Absent -- tyIsEmptyRow row = return $ (vDst `varmpOffsetUnit` LabelOffset_Off offset) `varUpd` (tv `varmpTyUnit` row) where (row,exts) = tyRowExtsWithLkup (varmpTyLookupCyc2 subst') ty ((offset,presence),_) = tyExtsOffset lab' $ rowCanonOrder exts (Label_Lab lab') = varUpd subst' lab chk _ = Nothing {-# LINE 304 "src/ehc/CHR/CtxtRedOnly/Instances.chs" #-} instance IsCHRConstraint FIIn Constraint VarMp instance IsCHRGuard FIIn Guard VarMp -- instance IsCHRPrio FIIn Prio VarMp