VarUpdatable now uses TypeFamilies

UU-ComputerScience · Oct 16, 2015 · ad4c6aa · ad4c6aa
1 parent 1fdbd29
commit ad4c6aa
Show file tree

Hide file tree

Showing 19 changed files with 116 additions and 56 deletions.
diff --git a/EHC/src/ehc/AnaDomain/Utils.chs b/EHC/src/ehc/AnaDomain/Utils.chs
@@ -108,23 +108,23 @@ relevQualRemoveAmbig bound qualS
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 
 %%[(8 codegenanalysis) hs
-instance VarUpdatable RelevTy RVarMp UID RVarMpInfo where
+instance VarUpdatable RelevTy RVarMp where
   varUpd = relevtyAppVarLookup
 
 instance VarExtractable RelevTy UID where
   varFreeSet = relevTyFtv
 %%]
 
 %%[(8 codegenanalysis) hs
-instance VarUpdatable RelevQual RVarMp UID RVarMpInfo where
+instance VarUpdatable RelevQual RVarMp where
   varUpd = relevqualAppVarLookup
 
 instance VarExtractable RelevQual UID where
   varFreeSet = relevQualFtv
 %%]
 
 %%[(8 codegenanalysis) hs
-instance VarUpdatable RelevCoe RVarMp UID RVarMpInfo where
+instance VarUpdatable RelevCoe RVarMp where
   varUpd = relevcoeAppVarLookup
 
 instance VarExtractable RelevCoe UID where

diff --git a/EHC/src/ehc/CHR/Constraint.chs b/EHC/src/ehc/CHR/Constraint.chs
@@ -105,7 +105,7 @@ instance (VarExtractable p v,VarExtractable info v) => VarExtractable (Constrain
         Just (_,p,_) -> varFreeSet p
         _            -> Set.empty
 
-instance (VarUpdatable p s VarId VarMpInfo,VarUpdatable info s VarId VarMpInfo) => VarUpdatable (Constraint p info) s VarId VarMpInfo where
+instance (VarUpdatable p s,VarUpdatable info s) => VarUpdatable (Constraint p info) s where
   varUpd s      (Prove     p       ) = Prove      (varUpd s p)
   varUpd s      (Assume    p       ) = Assume     (varUpd s p)
   varUpd s      r@(Reduction {cnstrPred=p, cnstrInfo=i, cnstrFromPreds=ps})

diff --git a/EHC/src/ehc/CHR/Solve.chs b/EHC/src/ehc/CHR/Solve.chs
@@ -430,7 +430,7 @@ chrSolve
      , CHRMatchable env p s, CHRCheckable env g s
      -- , VarUpdatable s s, VarUpdatable g s, VarUpdatable i s, VarUpdatable p s
      , VarLookupCmb s s
-     , VarUpdatable s s VarId VarMpInfo, VarUpdatable g s VarId VarMpInfo, VarUpdatable i s VarId VarMpInfo, VarUpdatable p s VarId VarMpInfo
+     , VarUpdatable s s, VarUpdatable g s, VarUpdatable i s, VarUpdatable p s
      , CHREmptySubstitution s
      , Ord (Constraint p i)
 %%[[9
@@ -451,7 +451,7 @@ chrSolve'
      , CHRMatchable env p s, CHRCheckable env g s
      -- , VarUpdatable s s, VarUpdatable g s, VarUpdatable i s, VarUpdatable p s
      , VarLookupCmb s s
-     , VarUpdatable s s VarId VarMpInfo, VarUpdatable g s VarId VarMpInfo, VarUpdatable i s VarId VarMpInfo, VarUpdatable p s VarId VarMpInfo
+     , VarUpdatable s s, VarUpdatable g s, VarUpdatable i s, VarUpdatable p s
      , CHREmptySubstitution s
      , Ord (Constraint p i)
 %%[[9
@@ -475,7 +475,7 @@ chrSolve''
      , CHRMatchable env p s, CHRCheckable env g s
      -- , VarUpdatable s s, VarUpdatable g s, VarUpdatable i s, VarUpdatable p s
      , VarLookupCmb s s
-     , VarUpdatable s s VarId VarMpInfo, VarUpdatable g s VarId VarMpInfo, VarUpdatable i s VarId VarMpInfo, VarUpdatable p s VarId VarMpInfo
+     , VarUpdatable s s, VarUpdatable g s, VarUpdatable i s, VarUpdatable p s
      , CHREmptySubstitution s
      , Ord (Constraint p i)
 %%[[9

diff --git a/EHC/src/ehc/DerivationTree.chs b/EHC/src/ehc/DerivationTree.chs
@@ -162,13 +162,13 @@ dtVarMpL vm
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 
 %%[(99 hmtyinfer tyderivtree) hs export(dtEltTy,dtEltTy')
-dtEltTy' :: (VarUpdatable x VarMp VarId VarMpInfo, VarUpdatable x m VarId VarMpInfo) => (x -> TvCatMp) -> (x -> res) -> m -> VarMp -> x -> (res,VarMp)
+dtEltTy' :: (VarUpdatable x VarMp, VarUpdatable x m) => (x -> TvCatMp) -> (x -> res) -> m -> VarMp -> x -> (res,VarMp)
 dtEltTy' ftvmp mkres m dm t
   = (mkres (dm' `varUpd` t'), dm')
   where t'  = m `varUpd` t
         dm' = dtVmExtend (ftvmp t') dm
 
-dtEltTy :: (VarUpdatable Ty m sk sv) => m -> VarMp -> Ty -> (PP_Doc,VarMp)
+dtEltTy :: (VarUpdatable Ty m) => m -> VarMp -> Ty -> (PP_Doc,VarMp)
 dtEltTy = dtEltTy' tyFtvMp ppTyDt
 %%]
 
@@ -181,7 +181,7 @@ dtEltGam m dm g
 dtEltFoVarMp :: VarMp -> FIOut -> PP_Doc
 dtEltFoVarMp dm fo = ppVarMp ppCurlysCommas' (foVarMp fo)
 
-dtEltVarMp :: (VarLookup m TyVarId VarMpInfo, VarUpdatable VarMpInfo m TyVarId VarMpInfo) => m -> VarMp -> VarMp -> (PP_Doc,VarMp)
+dtEltVarMp :: (VarLookup m (VarUpdKey m) (VarUpdVal m), VarUpdKey m ~ TyVarId, VarUpdVal m ~ VarMpInfo, VarUpdatable VarMpInfo m) => m -> VarMp -> VarMp -> (PP_Doc,VarMp)
 dtEltVarMp m dm vm
   = (ppAssocL' ppBracketsCommas' ":->" [ (ppTyDt $ dm' `varUpd` varmpinfoMkVar tv i,ppVarMpInfoDt i) | (tv,i) <- varmpToAssocL vm'], dm')
   where (vm',dm')
@@ -192,6 +192,8 @@ dtEltVarMp m dm vm
                          ) dm vm
 %%]
 
+(VarLookup m (VarUpdKey m) (VarUpdVal m), VarUpdKey m ~ TyVarId, VarUpdVal m ~ VarMpInfo)
+
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 %%% Choose between final/infer variant
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

diff --git a/EHC/src/ehc/Gam.chs b/EHC/src/ehc/Gam.chs
@@ -220,7 +220,7 @@ idQualGamReplacement g k n = maybe n id $ gamLookup (IdOcc n k) g
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 
 %%[(2 hmtyinfer || hmtyast).Substitutable.Gam
-instance (Eq tk,VarUpdatable vv subst VarId VarMpInfo) => VarUpdatable (Gam tk vv) subst VarId VarMpInfo where
+instance (Eq tk, VarUpdatable vv subst) => VarUpdatable (Gam tk vv) subst where
   s `varUpd`  (Gam ll)    =   Gam (map (assocLMapElt (s `varUpd`)) ll)
 %%[[4
   s `varUpdCyc` (Gam ll)    =   (Gam ll',varmpUnions $ map (varmpUnions . assocLElts) m)
@@ -232,7 +232,7 @@ instance (Eq k,Eq tk,VarExtractable vv k) => VarExtractable (Gam tk vv) k where
 %%]
 
 %%[(8 hmtyinfer || hmtyast).Substitutable.SGam -2.Substitutable.Gam
-instance (Ord tk,VarUpdatable vv subst VarId VarMpInfo) => VarUpdatable (SGam tk vv) subst VarId VarMpInfo where
+instance (Ord tk, Ord (VarUpdKey subst), VarUpdatable vv subst) => VarUpdatable (SGam tk vv) subst where
   s `varUpd`  g    =   gamMapElts (s `varUpd`) g
 %%[[4
   s `varUpdCyc` g    =   (g',varmpUnions $ gamElts gm)

diff --git a/EHC/src/ehc/Gam/ClassDefaultGam.chs b/EHC/src/ehc/Gam/ClassDefaultGam.chs
@@ -15,6 +15,8 @@ Currently only the first one is used.
 %%]
 %%[(9 hmtyinfer) import({%{EH}Gam},{%{EH}Ty},{%{EH}VarMp})
 %%]
+%%[(9 hmtyinfer) import(UHC.Util.Substitutable)
+%%]
 %%[(9 hmtyinfer) import({%{EH}Ty.FitsInCommon2},{%{EH}Ty.FitsIn})
 %%]
 
@@ -53,6 +55,7 @@ clDfGamLookupDefault
   :: ( VarLookup gm TyVarId VarMpInfo
      -- , VarLookup gm Ty VarMpInfo
      , VarLookupCmb VarMp gm
+     , VarUpdKey gm ~ VarId, VarUpdVal gm ~ VarMpInfo
      )
      => FIIn' gm -> Pred -> ClassDefaultGam
      -> Maybe VarMp

diff --git a/EHC/src/ehc/Gam/PolGam.chs b/EHC/src/ehc/Gam/PolGam.chs
@@ -111,7 +111,7 @@ initPolGam
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 
 %%[(17 hmtyinfer || hmtyast).Substitutable.inst.PolGamInfo
-instance VarUpdatable PolGamInfo VarMp VarId VarMpInfo where
+instance VarUpdatable PolGamInfo VarMp where
   s `varUpd` pgi  = pgi { pgiPol = s `varUpd` pgiPol pgi }
   s `varUpdCyc` pgi = substLift pgiPol (\i x -> i {pgiPol = x}) varUpdCyc s pgi
 

diff --git a/EHC/src/ehc/Gam/TyGam.chs b/EHC/src/ehc/Gam/TyGam.chs
@@ -215,7 +215,7 @@ initTyGam
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 
 %%[(2 hmtyinfer || hmtyast).Substitutable.inst.TyGamInfo
-instance VarUpdatable TyGamInfo VarMp VarId VarMpInfo  where
+instance VarUpdatable TyGamInfo VarMp where
   s `varUpd`  tgi         =   tgi { tgiTy = s `varUpd` tgiTy tgi }
 %%[[4
   s `varUpdCyc` tgi         =   substLift tgiTy (\i x -> i {tgiTy = x}) varUpdCyc s tgi

diff --git a/EHC/src/ehc/Gam/TyKiGam.chs b/EHC/src/ehc/Gam/TyKiGam.chs
@@ -220,7 +220,7 @@ initTyKiGam
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 
 %%[(6 hmtyinfer || hmtyast).Substitutable.inst.TyKiGamInfo
-instance VarUpdatable TyKiGamInfo VarMp VarId VarMpInfo where
+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
 

diff --git a/EHC/src/ehc/Gam/ValGam.chs b/EHC/src/ehc/Gam/ValGam.chs
@@ -142,7 +142,7 @@ valGamRestrictKiVarMp g = varmpIncMetaLev $ assocTyLToVarMp [ (v,kiStar) | vgi <
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 
 %%[(2 hmtyinfer || hmtyast).Substitutable.inst.ValGamInfo
-instance VarUpdatable ValGamInfo VarMp VarId VarMpInfo where
+instance VarUpdatable ValGamInfo VarMp where
   s `varUpd`  vgi         =   vgi { vgiTy = s `varUpd` vgiTy vgi }
 %%[[4
   s `varUpdCyc` vgi         =   substLift vgiTy (\i x -> i {vgiTy = x}) varUpdCyc s vgi

diff --git a/EHC/src/ehc/Pred/CHR.chs b/EHC/src/ehc/Pred/CHR.chs
@@ -94,7 +94,7 @@ instance PP Guard where
 instance VarExtractable CHRPredOccCnstrMp TyVarId where
   varFreeSet        x = Set.unions [ varFreeSet k | k <- Map.keys x ]
 
-instance VarUpdatable CHRPredOccCnstrMp VarMp VarId VarMpInfo where
+instance VarUpdatable CHRPredOccCnstrMp VarMp where
   varUpd s x = Map.mapKeysWith (++) (varUpd s) x
 
 instance VarExtractable Guard TyVarId where
@@ -112,7 +112,7 @@ instance VarExtractable Guard TyVarId where
   varFreeSet        (EqualModuloUnification t1 t2)    = Set.unions [varFreeSet t1, varFreeSet t2]
 %%]]
 
-instance VarUpdatable Guard VarMp VarId VarMpInfo where
+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)
@@ -135,7 +135,7 @@ instance VarExtractable VarUIDHsName TyVarId where
   varFreeSet          _                 = Set.empty
 
 -- instance VarUpdatable VarUIDHsName VarMp where
-instance VarLookup m ImplsVarId VarMpInfo => VarUpdatable VarUIDHsName m ImplsVarId VarMpInfo where
+instance (VarLookup m (VarUpdKey m) (VarUpdVal m), VarUpdKey m ~ ImplsVarId, VarUpdVal m ~ VarMpInfo) => VarUpdatable VarUIDHsName m where
   varUpd s a                   = maybe a id $ varmpAssNmLookupAssNmCyc a s
 %%]
 
@@ -147,7 +147,7 @@ instance VarExtractable RedHowAnnotation TyVarId where
 %%]]
   varFreeSet        _                             = Set.empty
 
-instance VarUpdatable RedHowAnnotation VarMp VarId VarMpInfo where
+instance VarUpdatable RedHowAnnotation VarMp where
   varUpd s (RedHow_Assumption   vun sc)  = RedHow_Assumption (varUpd s vun) (varUpd s sc)
 %%[[10
   varUpd s (RedHow_ByLabel      l o sc)  = RedHow_ByLabel (varUpd s l) (varUpd s o) (varUpd s sc)

diff --git a/EHC/src/ehc/Pred/Evidence.chs b/EHC/src/ehc/Pred/Evidence.chs
@@ -77,7 +77,9 @@ instance VarExtractable p v => VarExtractable (Evidence p info) v where
   varFreeSet            (Evid_Recurse     p     )    = varFreeSet p
   varFreeSet            (Evid_Ambig       p  ess)    = Set.unions $ varFreeSet p : map (Set.unions . map varFreeSet . snd) ess
 
-instance VarUpdatable p s VarId VarMpInfo => VarUpdatable (Evidence p info) s VarId VarMpInfo where
+instance VarUpdatable p s => VarUpdatable (Evidence p info) s where
+  -- type VarUpdKey s = VarUpdKey s
+  -- type VarUpdVal s = VarUpdVal s
   varUpd s     (Evid_Unresolved  p   u )    = Evid_Unresolved (varUpd s p) u
   varUpd s     (Evid_Proof       p i es)    = Evid_Proof      (varUpd s p) i (map (varUpd s) es)
   varUpd s     (Evid_Recurse     p     )    = Evid_Recurse    (varUpd s p)  

diff --git a/EHC/src/ehc/Pred/ToCHR.chs b/EHC/src/ehc/Pred/ToCHR.chs
@@ -459,7 +459,7 @@ chrSimplifySolveToRedGraph
   :: ( Ord p, Ord i
      , CHRMatchable FIIn p s, CHRCheckable FIIn g s
      , VarLookupCmb s s
-     , VarUpdatable s s VarId VarMpInfo, VarUpdatable g s VarId VarMpInfo, VarUpdatable i s VarId VarMpInfo, VarUpdatable p s VarId VarMpInfo
+     , VarUpdatable s s, VarUpdatable g s, VarUpdatable i s, VarUpdatable p s
      , CHREmptySubstitution s
      , PP g, PP i, PP p -- for debugging
      ) => FIIn -> CHRStore p i g s -> ConstraintToInfoMap p i -> ConstraintToInfoMap p i