retrie 0.1.0.0 → 0.1.0.1

raw patch · 12 files changed

+492/−226 lines, 12 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG.md +8/−1
• README.md +1/−1
• Retrie/Options.hs +1/−1
• Retrie/PatternMap/Bag.hs +4/−2
• Retrie/PatternMap/Class.hs +18/−4
• Retrie/PatternMap/Instances.hs +340/−168
• Retrie/Universe.hs +4/−2
• Retrie/Util.hs +51/−41
• retrie.cabal +7/−1
• tests/Ignore.hs +4/−4
• tests/Util.hs +9/−1
• tests/inputs/Types4.test +45/−0

@@ -1,3 +1,10 @@-1.0.0 (March 16, 2020)+0.1.0.1 (April 1, 2020)++* Don't fail if 'git' or 'hg' commands cannot be found.+* Better error message when syntax support needs to be extended.+* Add support for following type syntax: lists, tuples, constraints, +  unboxed sums, and forall.++0.1.0.0 (March 16, 2020)  Initial release

@@ -295,7 +295,7 @@  To report other bugs, please create a GitHub issue. -[![Build Status](https://travis-ci.org/facebookincubator/retrie.svg?branch=master)](https://travis-ci.org/facebookincubator/retrie)+[![Build Status](https://travis-ci.com/facebookincubator/retrie.svg?branch=master)](https://travis-ci.com/facebookincubator/retrie)  # License 

@@ -347,7 +347,7 @@ -- This selects all files if the list of rewrites is empty getTargetFiles opts [] = getTargetFiles opts [mempty] getTargetFiles Options{..} gtss = do-  ignorePred <- maybe onIgnoreErr return =<< vcsIgnorePred targetDir+  ignorePred <- maybe onIgnoreErr return =<< vcsIgnorePred verbosity targetDir   let ignore fp = ignorePred fp || extraIgnorePred fp   fpSets <- forM (dedup gtss) $ \ gts -> do     -- See Note [Ground Terms]

@@ -35,8 +35,10 @@   mUnion :: BoolMap a -> BoolMap a -> BoolMap a   mUnion EmptyBoolMap m = m   mUnion m EmptyBoolMap = m-  mUnion (BoolMap tm1 fm1) (BoolMap tm2 fm2) =-    BoolMap (mUnion tm1 tm2) (mUnion fm1 fm2)+  mUnion m1 m2 = BoolMap+    { bmTrue = unionOn bmTrue m1 m2+    , bmFalse = unionOn bmFalse m1 m2+    }    mAlter     :: AlphaEnv -> Quantifiers -> Key BoolMap -> A a -> BoolMap a -> BoolMap a

@@ -38,6 +38,13 @@ -- TODO: Maybe a -> a ??? -- we never need to delete type A a = Maybe a -> Maybe a +missingSyntax :: String -> a+missingSyntax constructor = error $ unlines+  [ "Missing syntax support: " ++ constructor+  , "Please file an issue at https://github.com/facebookincubator/retrie/issues"+  , "with an example of the rewrite you are attempting and we'll add it."+  ]+ toA :: PatternMap m => (m a -> m a) -> A (m a) toA f = Just . f . fromMaybe mEmpty @@ -45,6 +52,9 @@ toAList f Nothing = (:[]) <$> f Nothing toAList f (Just xs) = Just $ mapMaybe (f . Just) xs +unionOn :: PatternMap m => (a -> m b) -> a -> a -> m b+unionOn f m1 m2 = mUnion (f m1) (f m2)+ ------------------------------------------------------------------------  class PatternMap m where@@ -94,9 +104,10 @@  ------------------------------------------------------------------------ -data ListMap m a-  = ListMap { lmNil  :: MaybeMap a-            , lmCons :: m (ListMap m a) }+data ListMap m a = ListMap+  { lmNil  :: MaybeMap a+  , lmCons :: m (ListMap m a)+  }   deriving (Functor)  instance PatternMap m => PatternMap (ListMap m) where@@ -106,7 +117,10 @@   mEmpty = ListMap mEmpty mEmpty    mUnion :: ListMap m a -> ListMap m a -> ListMap m a-  mUnion (ListMap n1 c1) (ListMap n2 c2) = ListMap (mUnion n1 n2) (mUnion c1 c2)+  mUnion m1 m2 = ListMap+    { lmNil = unionOn lmNil m1 m2+    , lmCons = unionOn lmCons m1 m2+    }    mAlter :: AlphaEnv -> Quantifiers -> Key (ListMap m) -> A a -> ListMap m a -> ListMap m a   mAlter env vs []     f m = m { lmNil  = mAlter env vs () f (lmNil m) }

@@ -37,7 +37,10 @@   mEmpty = TupArgMap mEmpty mEmpty    mUnion :: TupArgMap a -> TupArgMap a -> TupArgMap a-  mUnion (TupArgMap p1 m1) (TupArgMap p2 m2) = TupArgMap (mUnion p1 p2) (mUnion m1 m2)+  mUnion m1 m2 = TupArgMap+    { tamPresent = unionOn tamPresent m1 m2+    , tamMissing = unionOn tamMissing m1 m2+    }    mAlter :: AlphaEnv -> Quantifiers -> Key TupArgMap -> A a -> TupArgMap a -> TupArgMap a   mAlter env vs tupArg f m = go (unLoc tupArg)@@ -46,7 +49,7 @@       go (Present e) = m { tamPresent = mAlter env vs e  f (tamPresent m) } #else       go (Present _ e) = m { tamPresent = mAlter env vs e  f (tamPresent m) }-      go XTupArg{} = error "XTupArg"+      go XTupArg{} = missingSyntax "XTupArg" #endif       go (Missing _) = m { tamMissing = mAlter env vs () f (tamMissing m) } @@ -74,7 +77,10 @@   mEmpty = BoxityMap mEmpty mEmpty    mUnion :: BoxityMap a -> BoxityMap a -> BoxityMap a-  mUnion (BoxityMap b1 u1) (BoxityMap b2 u2) = BoxityMap (mUnion b1 b2) (mUnion u1 u2)+  mUnion m1 m2 = BoxityMap+    { boxBoxed = unionOn boxBoxed m1 m2+    , boxUnboxed = unionOn boxUnboxed m1 m2+    }    mAlter :: AlphaEnv -> Quantifiers -> Key BoxityMap -> A a -> BoxityMap a -> BoxityMap a   mAlter env vs Boxed   f m = m { boxBoxed   = mAlter env vs () f (boxBoxed m) }@@ -99,7 +105,10 @@   mUnion :: VMap a -> VMap a -> VMap a   mUnion VMEmpty m = m   mUnion m VMEmpty = m-  mUnion (VM b1 f1) (VM b2 f2) = VM (mUnion b1 b2) (mUnion f1 f2)+  mUnion m1 m2 = VM+    { bvmap = unionOn bvmap m1 m2+    , fvmap = unionOn fvmap m1 m2+    }    mAlter :: AlphaEnv -> Quantifiers -> Key VMap -> A a -> VMap a -> VMap a   mAlter env vs v f VMEmpty = mAlter env vs v f (VM mEmpty mEmpty)@@ -143,17 +152,17 @@   mUnion :: LMap a -> LMap a -> LMap a   mUnion LMEmpty m = m   mUnion m LMEmpty = m-  mUnion (LM a1 b1 c1 d1 e1 f1 g1 h1 i1)-         (LM a2 b2 c2 d2 e2 f2 g2 h2 i2) =-          LM (mUnion a1 a2)-             (mUnion b1 b2)-             (mUnion c1 c2)-             (mUnion d1 d2)-             (mUnion e1 e2)-             (mUnion f1 f2)-             (mUnion g1 g2)-             (mUnion h1 h2)-             (mUnion i1 i2)+  mUnion m1 m2 = LM+    { lmChar = unionOn lmChar m1 m2+    , lmCharPrim = unionOn lmCharPrim m1 m2+    , lmString = unionOn lmString m1 m2+    , lmStringPrim = unionOn lmStringPrim m1 m2+    , lmInt = unionOn lmInt m1 m2+    , lmIntPrim = unionOn lmIntPrim m1 m2+    , lmWordPrim = unionOn lmWordPrim m1 m2+    , lmInt64Prim = unionOn lmInt64Prim m1 m2+    , lmWord64Prim = unionOn lmWord64Prim m1 m2+    }    mAlter :: AlphaEnv -> Quantifiers -> Key LMap -> A a -> LMap a -> LMap a   mAlter env vs lit f LMEmpty = mAlter env vs lit f emptyLMapWrapper@@ -169,13 +178,13 @@       go (HsWordPrim _ i)   = m { lmWordPrim = mAlter env vs i f (lmWordPrim m) }       go (HsInt64Prim _ i)  = m { lmInt64Prim = mAlter env vs i f (lmInt64Prim m) }       go (HsWord64Prim _ i) = m { lmWord64Prim = mAlter env vs i f (lmWord64Prim m) }-      go (HsInteger _ _ _) = error "HsInteger"-      go HsRat{} = error "HsRat"-      go HsFloatPrim{} = error "HsFloatPrim"-      go HsDoublePrim{} = error "HsDoublePrim"+      go (HsInteger _ _ _) = missingSyntax "HsInteger"+      go HsRat{} = missingSyntax "HsRat"+      go HsFloatPrim{} = missingSyntax "HsFloatPrim"+      go HsDoublePrim{} = missingSyntax "HsDoublePrim" #if __GLASGOW_HASKELL__ < 806 #else-      go XLit{} = error "XLit"+      go XLit{} = missingSyntax "XLit" #endif    mMatch :: MatchEnv -> Key LMap -> (Substitution, LMap a) -> [(Substitution, a)]@@ -216,8 +225,11 @@   mUnion :: OLMap a -> OLMap a -> OLMap a   mUnion OLMEmpty m = m   mUnion m OLMEmpty = m-  mUnion (OLM a1 b1 c1) (OLM a2 b2 c2) =-    OLM (mUnion a1 a2) (mUnion b1 b2) (mUnion c1 c2)+  mUnion m1 m2 = OLM+    { olmIntegral = unionOn olmIntegral m1 m2+    , olmFractional = unionOn olmFractional m1 m2+    , olmIsString = unionOn olmIsString m1 m2+    }    mAlter :: AlphaEnv -> Quantifiers -> Key OLMap -> A a -> OLMap a -> OLMap a   mAlter env vs lv f OLMEmpty = mAlter env vs lv f emptyOLMapWrapper@@ -309,29 +321,29 @@   mUnion :: EMap a -> EMap a -> EMap a   mUnion EMEmpty m = m   mUnion m EMEmpty = m-  mUnion (EM a1 b1 c1 d1 e1 f1 g1 h1 i1 j1 k1 l1 m1 n1 o1 p1 q1 r1 s1 t1 u1)-         (EM a2 b2 c2 d2 e2 f2 g2 h2 i2 j2 k2 l2 m2 n2 o2 p2 q2 r2 s2 t2 u2) =-          EM (mUnion a1 a2)-             (mUnion b1 b2)-             (mUnion c1 c2)-             (mUnion d1 d2)-             (mUnion e1 e2)-             (mUnion f1 f2)-             (mUnion g1 g2)-             (mUnion h1 h2)-             (mUnion i1 i2)-             (mUnion j1 j2)-             (mUnion k1 k2)-             (mUnion l1 l2)-             (mUnion m1 m2)-             (mUnion n1 n2)-             (mUnion o1 o2)-             (mUnion p1 p2)-             (mUnion q1 q2)-             (mUnion r1 r2)-             (mUnion s1 s2)-             (mUnion t1 t2)-             (mUnion u1 u2)+  mUnion m1 m2 = EM+    { emHole = unionOn emHole m1 m2+    , emVar = unionOn emVar m1 m2+    , emIPVar = unionOn emIPVar m1 m2+    , emOverLit = unionOn emOverLit m1 m2+    , emLit = unionOn emLit m1 m2+    , emLam = unionOn emLam m1 m2+    , emApp = unionOn emApp m1 m2+    , emOpApp = unionOn emOpApp m1 m2+    , emNegApp = unionOn emNegApp m1 m2+    , emPar = unionOn emPar m1 m2+    , emExplicitTuple = unionOn emExplicitTuple m1 m2+    , emCase = unionOn emCase m1 m2+    , emSecL = unionOn emSecL m1 m2+    , emSecR = unionOn emSecR m1 m2+    , emIf = unionOn emIf m1 m2+    , emLet = unionOn emLet m1 m2+    , emDo = unionOn emDo m1 m2+    , emExplicitList = unionOn emExplicitList m1 m2+    , emRecordCon = unionOn emRecordCon m1 m2+    , emRecordUpd = unionOn emRecordUpd m1 m2+    , emExprWithTySig = unionOn emExprWithTySig m1 m2+    }    mAlter :: AlphaEnv -> Quantifiers -> Key EMap -> A a -> EMap a -> EMap a   mAlter env vs e f EMEmpty = mAlter env vs e f emptyEMapWrapper@@ -413,7 +425,7 @@         m { emSecL = mAlter env vs o (toA (mAlter env vs lhs f)) (emSecL m) }       go (SectionR _ o rhs) =         m { emSecR = mAlter env vs o (toA (mAlter env vs rhs f)) (emSecR m) }-      go XExpr{} = error "XExpr"+      go XExpr{} = missingSyntax "XExpr"       go (HsLet _ lbs e') = #endif         let@@ -421,10 +433,10 @@           env' = foldr extendAlphaEnvInternal env bs           vs' = vs `exceptQ` bs         in m { emLet = mAlter env vs (unLoc lbs) (toA (mAlter env' vs' e' f)) (emLet m) }-      go HsLamCase{}      = error "HsLamCase"-      go HsMultiIf{} = error "HsMultiIf"+      go HsLamCase{} = missingSyntax "HsLamCase"+      go HsMultiIf{} = missingSyntax "HsMultiIf"       go (ExplicitList _ _ es) = m { emExplicitList = mAlter env vs es f (emExplicitList m) }-      go ArithSeq{} = error "ArithSeq"+      go ArithSeq{} = missingSyntax "ArithSeq" #if __GLASGOW_HASKELL__ < 806       go (ExprWithTySig e' (HsWC _ (HsIB _ ty _))) =         m { emExprWithTySig = mAlter env vs e' (toA (mAlter env vs ty f)) (emExprWithTySig m) }@@ -435,37 +447,37 @@       go (ExprWithTySig _ e' (HsWC _ (HsIB _ ty))) = #endif         m { emExprWithTySig = mAlter env vs e' (toA (mAlter env vs ty f)) (emExprWithTySig m) }-      go ExprWithTySig{} = error "ExprWithTySig"+      go ExprWithTySig{} = missingSyntax "ExprWithTySig" #endif-      go HsSCC{} = error "HsSCC"-      go HsCoreAnn{} = error "HsCoreAnn"-      go HsBracket{} = error "HsBracket"-      go HsRnBracketOut{} = error "HsRnBracketOut"-      go HsTcBracketOut{} = error "HsTcBracketOut"-      go HsSpliceE{} = error "HsSpliceE"-      go HsProc{} = error "HsProc"-      go HsStatic{} = error "HsStatic"-      go HsArrApp{} = error "HsArrApp"-      go HsArrForm{} = error "HsArrForm"-      go HsTick{} = error "HsTick"-      go HsBinTick{} = error "HsBinTick"-      go HsTickPragma{} = error "HsTickPragma"-      go EWildPat{} = error "EWildPat"-      go EAsPat{} = error "EAsPat"-      go EViewPat{} = error "EViewPat"-      go ELazyPat{} = error "ELazyPat"-      go HsWrap{} = error "HsWrap"-      go HsUnboundVar{} = error "HsUnboundVar"-      go HsRecFld{} = error "HsRecFld"-      go HsOverLabel{} = error "HsOverLabel"-      go HsAppType{} = error "HsAppType"-      go HsConLikeOut{} = error "HsConLikeOut"-      go ExplicitSum{} = error "ExplicitSum"+      go HsSCC{} = missingSyntax "HsSCC"+      go HsCoreAnn{} = missingSyntax "HsCoreAnn"+      go HsBracket{} = missingSyntax "HsBracket"+      go HsRnBracketOut{} = missingSyntax "HsRnBracketOut"+      go HsTcBracketOut{} = missingSyntax "HsTcBracketOut"+      go HsSpliceE{} = missingSyntax "HsSpliceE"+      go HsProc{} = missingSyntax "HsProc"+      go HsStatic{} = missingSyntax "HsStatic"+      go HsArrApp{} = missingSyntax "HsArrApp"+      go HsArrForm{} = missingSyntax "HsArrForm"+      go HsTick{} = missingSyntax "HsTick"+      go HsBinTick{} = missingSyntax "HsBinTick"+      go HsTickPragma{} = missingSyntax "HsTickPragma"+      go EWildPat{} = missingSyntax "EWildPat"+      go EAsPat{} = missingSyntax "EAsPat"+      go EViewPat{} = missingSyntax "EViewPat"+      go ELazyPat{} = missingSyntax "ELazyPat"+      go HsWrap{} = missingSyntax "HsWrap"+      go HsUnboundVar{} = missingSyntax "HsUnboundVar"+      go HsRecFld{} = missingSyntax "HsRecFld"+      go HsOverLabel{} = missingSyntax "HsOverLabel"+      go HsAppType{} = missingSyntax "HsAppType"+      go HsConLikeOut{} = missingSyntax "HsConLikeOut"+      go ExplicitSum{} = missingSyntax "ExplicitSum" #if __GLASGOW_HASKELL__ < 806-      go ExplicitPArr{} = error "ExplicitPArr"-      go ExprWithTySigOut{} = error "ExprWithTySigOut"-      go HsAppTypeOut{} = error "HsAppTypeOut"-      go PArrSeq{} = error "PArrSeq"+      go ExplicitPArr{} = missingSyntax "ExplicitPArr"+      go ExprWithTySigOut{} = missingSyntax "ExprWithTySigOut"+      go HsAppTypeOut{} = missingSyntax "HsAppTypeOut"+      go PArrSeq{} = missingSyntax "PArrSeq" #endif    mMatch :: MatchEnv -> Key EMap -> (Substitution, EMap a) -> [(Substitution, a)]@@ -596,8 +608,11 @@   mUnion :: SCMap a -> SCMap a -> SCMap a   mUnion SCEmpty m = m   mUnion m SCEmpty = m-  mUnion (SCM a1 b1 c1) (SCM a2 b2 c2) =-    SCM (mUnion a1 a2) (mUnion b1 b2) (mUnion c1 c2)+  mUnion m1 m2 = SCM+    { scmListComp = unionOn scmListComp m1 m2+    , scmMonadComp = unionOn scmMonadComp m1 m2+    , scmDoExpr = unionOn scmDoExpr m1 m2+    }    mAlter :: AlphaEnv -> Quantifiers -> Key SCMap -> A a -> SCMap a -> SCMap a   mAlter env vs sc f SCEmpty = mAlter env vs sc f emptySCMapWrapper@@ -606,15 +621,15 @@       go ListComp = m { scmListComp = mAlter env vs () f (scmListComp m) }       go MonadComp = m { scmMonadComp = mAlter env vs () f (scmMonadComp m) } #if __GLASGOW_HASKELL__ < 806-      go PArrComp = error "PArrComp"+      go PArrComp = missingSyntax "PArrComp" #endif       go DoExpr = m { scmDoExpr = mAlter env vs () f (scmDoExpr m) }-      go MDoExpr = error "MDoExpr"-      go ArrowExpr = error "ArrowExpr"-      go GhciStmtCtxt = error "GhciStmtCtxt"-      go (PatGuard _) = error "PatGuard"-      go (ParStmtCtxt _) = error "ParStmtCtxt"-      go (TransStmtCtxt _) = error "TransStmtCtxt"+      go MDoExpr = missingSyntax "MDoExpr"+      go ArrowExpr = missingSyntax "ArrowExpr"+      go GhciStmtCtxt = missingSyntax "GhciStmtCtxt"+      go (PatGuard _) = missingSyntax "PatGuard"+      go (ParStmtCtxt _) = missingSyntax "ParStmtCtxt"+      go (TransStmtCtxt _) = missingSyntax "TransStmtCtxt"    mMatch :: MatchEnv -> Key SCMap -> (Substitution, SCMap a) -> [(Substitution, a)]   mMatch _   _  (_,SCEmpty)  = []@@ -703,14 +718,17 @@   mUnion :: CDMap a -> CDMap a -> CDMap a   mUnion CDEmpty m = m   mUnion m CDEmpty = m-  mUnion (CDMap a1 b1) (CDMap a2 b2) = CDMap (mUnion a1 a2) (mUnion b1 b2)+  mUnion m1 m2 = CDMap+    { cdPrefixCon = unionOn cdPrefixCon m1 m2+    , cdInfixCon = unionOn cdInfixCon m1 m2+    }    mAlter :: AlphaEnv -> Quantifiers -> Key CDMap -> A a -> CDMap a -> CDMap a   mAlter env vs d f CDEmpty   = mAlter env vs d f emptyCDMapWrapper   mAlter env vs d f m@CDMap{} = go d     where       go (PrefixCon ps) = m { cdPrefixCon = mAlter env vs ps f (cdPrefixCon m) }-      go (RecCon _) = error "RecCon"+      go (RecCon _) = missingSyntax "RecCon"       go (InfixCon p1 p2) = m { cdInfixCon = mAlter env vs p1                                               (toA (mAlter env vs p2 f))                                               (cdInfixCon m) }@@ -753,14 +771,14 @@   mUnion :: PatMap a -> PatMap a -> PatMap a   mUnion PatEmpty m = m   mUnion m PatEmpty = m-  mUnion (PatMap a1 b1 c1 d1 e1 f1)-         (PatMap a2 b2 c2 d2 e2 f2) =-          PatMap (mUnion a1 a2)-                 (mUnion b1 b2)-                 (mUnion c1 c2)-                 (mUnion d1 d2)-                 (mUnion e1 e2)-                 (mUnion f1 f2)+  mUnion m1 m2 = PatMap+    { pmHole = unionOn pmHole m1 m2+    , pmWild = unionOn pmWild m1 m2+    , pmVar = unionOn pmVar m1 m2+    , pmParPat = unionOn pmParPat m1 m2+    , pmTuplePat = unionOn pmTuplePat m1 m2+    , pmConPatIn = unionOn pmConPatIn m1 m2+    }    mAlter :: AlphaEnv -> Quantifiers -> Key PatMap -> A a -> PatMap a -> PatMap a   mAlter env vs pat f PatEmpty   = mAlter env vs pat f emptyPatMapWrapper@@ -774,33 +792,33 @@ #endif         | unLoc v `isQ` vs = m { pmHole  = mAlter env vs (unLoc v) f (pmHole m) }         | otherwise        = m { pmVar   = mAlter env vs () f (pmVar m) } -- See Note [Variable Binders]-      go LazyPat{} = error "LazyPat"-      go AsPat{} = error "AsPat"-      go BangPat{} = error "BangPat"-      go ListPat{} = error "ListPat"+      go LazyPat{} = missingSyntax "LazyPat"+      go AsPat{} = missingSyntax "AsPat"+      go BangPat{} = missingSyntax "BangPat"+      go ListPat{} = missingSyntax "ListPat"       go (ConPatIn c d) = m { pmConPatIn = mAlter env vs (rdrFS (unLoc c)) (toA (mAlter env vs d f)) (pmConPatIn m) }-      go ConPatOut{} = error "ConPatOut"-      go ViewPat{} = error "ViewPat"-      go SplicePat{} = error "SplicePat"-      go LitPat{} = error "LitPat"-      go NPat{} = error "NPat"-      go NPlusKPat{} = error "NPlusKPat"+      go ConPatOut{} = missingSyntax "ConPatOut"+      go ViewPat{} = missingSyntax "ViewPat"+      go SplicePat{} = missingSyntax "SplicePat"+      go LitPat{} = missingSyntax "LitPat"+      go NPat{} = missingSyntax "NPat"+      go NPlusKPat{} = missingSyntax "NPlusKPat" #if __GLASGOW_HASKELL__ < 806-      go (PArrPat _ _) = error "PArrPat"+      go (PArrPat _ _) = missingSyntax "PArrPat"       go (ParPat p) = m { pmParPat = mAlter env vs p f (pmParPat m) }-      go (SigPatIn _ _) = error "SigPatIn"-      go (SigPatOut _ _) = error "SigPatOut"+      go (SigPatIn _ _) = missingSyntax "SigPatIn"+      go (SigPatOut _ _) = missingSyntax "SigPatOut"       go (TuplePat ps b _tys) =         m { pmTuplePat = mAlter env vs b (toA (mAlter env vs ps f)) (pmTuplePat m) } #else       go (ParPat _ p) = m { pmParPat = mAlter env vs p f (pmParPat m) }       go (TuplePat _ ps b) =         m { pmTuplePat = mAlter env vs b (toA (mAlter env vs ps f)) (pmTuplePat m) }-      go SigPat{} = error "SigPat"-      go XPat{} = error "XPat"+      go SigPat{} = missingSyntax "SigPat"+      go XPat{} = missingSyntax "XPat" #endif-      go CoPat{} = error "CoPat"-      go SumPat{} = error "SumPat"+      go CoPat{} = missingSyntax "CoPat"+      go SumPat{} = missingSyntax "SumPat"    mMatch :: MatchEnv -> Key PatMap -> (Substitution, PatMap a) -> [(Substitution, a)]   mMatch _   _   (_ ,PatEmpty)   = []@@ -875,7 +893,7 @@ #if __GLASGOW_HASKELL__ < 806   mAlter env vs (GRHS gs b) f (GRHSMap m) = #else-  mAlter _ _ XGRHS{} _ _ = error "XGRHS"+  mAlter _ _ XGRHS{} _ _ = missingSyntax "XGRHS"   mAlter env vs (GRHS _ gs b) f (GRHSMap m) = #endif     let bs = collectLStmtsBinders gs@@ -916,7 +934,10 @@   mUnion :: SLMap a -> SLMap a -> SLMap a   mUnion SLEmpty m = m   mUnion m SLEmpty = m-  mUnion (SLM a1 b1) (SLM a2 b2) = SLM (mUnion a1 a2) (mUnion b1 b2)+  mUnion m1 m2 = SLM+    { slmNil = unionOn slmNil m1 m2+    , slmCons = unionOn slmCons m1 m2+    }    mAlter :: AlphaEnv -> Quantifiers -> Key SLMap -> A a -> SLMap a -> SLMap a   mAlter env vs ss f SLEmpty = mAlter env vs ss f emptySLMapWrapper@@ -967,8 +988,10 @@   mUnion :: LBMap a -> LBMap a -> LBMap a   mUnion LBEmpty m = m   mUnion m LBEmpty = m-  mUnion (LB a1 b1) (LB a2 b2) =-    LB (mUnion a1 a2) (mUnion b1 b2)+  mUnion m1 m2 = LB+    { lbValBinds = unionOn lbValBinds m1 m2+    , lbEmpty = unionOn lbEmpty m1 m2+    }    mAlter :: AlphaEnv -> Quantifiers -> Key LBMap -> A a -> LBMap a -> LBMap a   mAlter env vs lbs f LBEmpty = mAlter env vs lbs f emptyLBMapWrapper@@ -979,7 +1002,7 @@       go (HsValBinds vbs) = #else       go (EmptyLocalBinds _) = m { lbEmpty = mAlter env vs () f (lbEmpty m) }-      go XHsLocalBindsLR{} = error "XHsLocalBindsLR"+      go XHsLocalBindsLR{} = missingSyntax "XHsLocalBindsLR"       go (HsValBinds _ vbs) = #endif         let@@ -987,7 +1010,7 @@           env' = foldr extendAlphaEnvInternal env bs           vs' = vs `exceptQ` bs         in m { lbValBinds = mAlter env' vs' (deValBinds vbs) f (lbValBinds m) }-      go HsIPBinds{} = error "HsIPBinds"+      go HsIPBinds{} = missingSyntax "HsIPBinds"    mMatch :: MatchEnv -> Key LBMap -> (Substitution, LBMap a) -> [(Substitution, a)]   mMatch _   _   (_,LBEmpty) = []@@ -1041,8 +1064,11 @@   mUnion :: BMap a -> BMap a -> BMap a   mUnion BMEmpty m = m   mUnion m BMEmpty = m-  mUnion (BM a1 b1 c1) (BM a2 b2 c2)-    = BM (mUnion a1 a2) (mUnion b1 b2) (mUnion c1 c2)+  mUnion m1 m2 = BM+    { bmFunBind = unionOn bmFunBind m1 m2+    , bmVarBind = unionOn bmVarBind m1 m2+    , bmPatBind = unionOn bmPatBind m1 m2+    }    mAlter :: AlphaEnv -> Quantifiers -> Key BMap -> A a -> BMap a -> BMap a   mAlter env vs b f BMEmpty = mAlter env vs b f emptyBMapWrapper@@ -1055,13 +1081,13 @@ #else       go (FunBind _ _ mg _ _) = m { bmFunBind = mAlter env vs mg f (bmFunBind m) }       go (VarBind _ _ e _) = m { bmVarBind = mAlter env vs e f (bmVarBind m) }-      go XHsBindsLR{} = error "XHsBindsLR"+      go XHsBindsLR{} = missingSyntax "XHsBindsLR"       go (PatBind _ lhs rhs _) = #endif         m { bmPatBind = mAlter env vs lhs               (toA $ mAlter env vs rhs f) (bmPatBind m) }-      go AbsBinds{} = error "AbsBinds"-      go PatSynBind{} = error "PatSynBind"+      go AbsBinds{} = missingSyntax "AbsBinds"+      go PatSynBind{} = missingSyntax "PatSynBind"    mMatch :: MatchEnv -> Key BMap -> (Substitution, BMap a) -> [(Substitution, a)]   mMatch _   _ (_,BMEmpty) = []@@ -1102,8 +1128,11 @@   mUnion :: SMap a -> SMap a -> SMap a   mUnion SMEmpty m = m   mUnion m SMEmpty = m-  mUnion (SM a1 b1 c1) (SM a2 b2 c2) =-    SM (mUnion a1 a2) (mUnion b1 b2) (mUnion c1 c2)+  mUnion m1 m2 = SM+    { smLastStmt = unionOn smLastStmt m1 m2+    , smBindStmt = unionOn smBindStmt m1 m2+    , smBodyStmt = unionOn smBodyStmt m1 m2+    }    mAlter :: AlphaEnv -> Quantifiers -> Key SMap -> A a -> SMap a -> SMap a   mAlter env vs s f SMEmpty = mAlter env vs s f emptySMapWrapper@@ -1116,7 +1145,7 @@ #else       go (BodyStmt _ e _ _) = m { smBodyStmt = mAlter env vs e f (smBodyStmt m) }       go (LastStmt _ e _ _)   = m { smLastStmt = mAlter env vs e f (smLastStmt m) }-      go XStmtLR{} = error "XStmtLR"+      go XStmtLR{} = missingSyntax "XStmtLR"       go (BindStmt _ p e _ _) = #endif         let bs = collectPatBinders p@@ -1124,11 +1153,11 @@             vs' = vs `exceptQ` bs         in m { smBindStmt = mAlter env vs p                               (toA (mAlter env' vs' e f)) (smBindStmt m) }-      go LetStmt{} = error "LetStmt"-      go ParStmt{} = error "ParStmt"-      go TransStmt{} = error "TransStmt"-      go RecStmt{} = error "RecStmt"-      go ApplicativeStmt{} = error "ApplicativeStmt"+      go LetStmt{} = missingSyntax "LetStmt"+      go ParStmt{} = missingSyntax "ParStmt"+      go TransStmt{} = missingSyntax "TransStmt"+      go RecStmt{} = missingSyntax "RecStmt"+      go ApplicativeStmt{} = missingSyntax "ApplicativeStmt"    mMatch :: MatchEnv -> Key SMap -> (Substitution, SMap a) -> [(Substitution, a)]   mMatch _   _   (_,SMEmpty) = []@@ -1154,22 +1183,28 @@   = TyEmpty   | TM { tyHole    :: Map RdrName a -- See Note [Holes]        , tyHsTyVar :: VMap a-       , tyHsFunTy :: TyMap (TyMap a)        , tyHsAppTy :: TyMap (TyMap a) #if __GLASGOW_HASKELL__ < 806        , tyHsAppsTy :: ListMap AppTyMap a #endif+       , tyHsForAllTy :: ForAllTyMap a -- See Note [Telescope]+       , tyHsFunTy :: TyMap (TyMap a)+       , tyHsListTy :: TyMap a        , tyHsParTy :: TyMap a+       , tyHsQualTy :: TyMap (ListMap TyMap a)+       , tyHsSumTy :: ListMap TyMap a+       , tyHsTupleTy :: TupleSortMap (ListMap TyMap a)          -- TODO: the rest        }   deriving (Functor)  emptyTyMapWrapper :: TyMap a-emptyTyMapWrapper =-  TM mEmpty mEmpty mEmpty mEmpty mEmpty+emptyTyMapWrapper = TM+  mEmpty mEmpty mEmpty #if __GLASGOW_HASKELL__ < 806-     mEmpty+  mEmpty #endif+  mEmpty mEmpty mEmpty mEmpty mEmpty mEmpty mEmpty  instance PatternMap TyMap where   type Key TyMap = LHsType GhcPs@@ -1180,15 +1215,21 @@   mUnion :: TyMap a -> TyMap a -> TyMap a   mUnion TyEmpty m = m   mUnion m TyEmpty = m+  mUnion m1 m2 = TM+    { tyHole = unionOn tyHole m1 m2+    , tyHsTyVar = unionOn tyHsTyVar m1 m2+    , tyHsAppTy = unionOn tyHsAppTy m1 m2 #if __GLASGOW_HASKELL__ < 806-  mUnion (TM a1 b1 c1 d1 e1 f1) (TM a2 b2 c2 d2 e2 f2) =-    TM (mUnion a1 a2) (mUnion b1 b2) (mUnion c1 c2) (mUnion d1 d2)-       (mUnion e1 e2) (mUnion f1 f2)-#else-  mUnion (TM a1 b1 c1 d1 e1) (TM a2 b2 c2 d2 e2) =-    TM (mUnion a1 a2) (mUnion b1 b2) (mUnion c1 c2) (mUnion d1 d2)-       (mUnion e1 e2)+    , tyHsAppsTy = unionOn tyHsAppsTy m1 m2 #endif+    , tyHsForAllTy = unionOn tyHsForAllTy m1 m2+    , tyHsFunTy = unionOn tyHsFunTy m1 m2+    , tyHsListTy = unionOn tyHsListTy m1 m2+    , tyHsParTy = unionOn tyHsParTy m1 m2+    , tyHsQualTy = unionOn tyHsQualTy m1 m2+    , tyHsSumTy = unionOn tyHsSumTy m1 m2+    , tyHsTupleTy = unionOn tyHsTupleTy m1 m2+    }    mAlter :: AlphaEnv -> Quantifiers -> Key TyMap -> A a -> TyMap a -> TyMap a   mAlter env vs ty f TyEmpty = mAlter env vs ty f emptyTyMapWrapper@@ -1206,40 +1247,49 @@ #endif         | v `isQ` vs = m { tyHole    = mAlter env vs v f (tyHole m) }         | otherwise  = m { tyHsTyVar = mAlter env vs v f (tyHsTyVar m) }-      go HsForAllTy{} = error "HsForAllTy"-      go HsQualTy{} = error "HsQualTy"-      go HsListTy{} = error "HsListTy"-      go HsTupleTy{} = error "HsTupleTy"-      go HsOpTy{} = error "HsOpTy"-      go HsIParamTy{} = error "HsIParamTy"-      go HsKindSig{} = error "HsKindSig"-      go HsSpliceTy{} = error "HsSpliceTy"-      go HsDocTy{} = error "HsDocTy"-      go HsBangTy{} = error "HsBangTy"-      go HsRecTy{} = error "HsRecTy"+      go HsOpTy{} = missingSyntax "HsOpTy"+      go HsIParamTy{} = missingSyntax "HsIParamTy"+      go HsKindSig{} = missingSyntax "HsKindSig"+      go HsSpliceTy{} = missingSyntax "HsSpliceTy"+      go HsDocTy{} = missingSyntax "HsDocTy"+      go HsBangTy{} = missingSyntax "HsBangTy"+      go HsRecTy{} = missingSyntax "HsRecTy" #if __GLASGOW_HASKELL__ < 806       go (HsAppsTy atys) = m { tyHsAppsTy = mAlter env vs atys f (tyHsAppsTy m) }       go (HsAppTy ty1 ty2) = m { tyHsAppTy = mAlter env vs ty1 (toA (mAlter env vs ty2 f)) (tyHsAppTy m) }+      go (HsCoreTy _) = missingSyntax "HsCoreTy"+      go (HsEqTy _ _) = missingSyntax "HsEqTy"+      go (HsForAllTy bndrs ty') = m { tyHsForAllTy = mAlter env vs (bndrs, ty') f (tyHsForAllTy m) }       go (HsFunTy ty1 ty2) = m { tyHsFunTy = mAlter env vs ty1 (toA (mAlter env vs ty2 f)) (tyHsFunTy m) }-      go (HsCoreTy _) = error "HsCoreTy"-      go (HsEqTy _ _) = error "HsEqTy"+      go (HsListTy ty') = m { tyHsListTy = mAlter env vs ty' f (tyHsListTy m) }       go (HsParTy ty') = m { tyHsParTy = mAlter env vs ty' f (tyHsParTy m) }-      go (HsPArrTy _) = error "HsPArrTy"+      go (HsPArrTy _) = missingSyntax "HsPArrTy"+      go (HsQualTy (L _ cons) ty') =+        m { tyHsQualTy = mAlter env vs ty' (toA (mAlter env vs cons f)) (tyHsQualTy m) }+      go (HsSumTy tys) = m { tyHsSumTy = mAlter env vs tys f (tyHsSumTy m) }+      go (HsTupleTy ts tys) =+        m { tyHsTupleTy = mAlter env vs ts (toA (mAlter env vs tys f)) (tyHsTupleTy m) } #else       go (HsAppTy _ ty1 ty2) = m { tyHsAppTy = mAlter env vs ty1 (toA (mAlter env vs ty2 f)) (tyHsAppTy m) }+      go (HsForAllTy _ bndrs ty') = m { tyHsForAllTy = mAlter env vs (bndrs, ty') f (tyHsForAllTy m) }       go (HsFunTy _ ty1 ty2) = m { tyHsFunTy = mAlter env vs ty1 (toA (mAlter env vs ty2 f)) (tyHsFunTy m) }+      go (HsListTy _ ty') = m { tyHsListTy = mAlter env vs ty' f (tyHsListTy m) }       go (HsParTy _ ty') = m { tyHsParTy = mAlter env vs ty' f (tyHsParTy m) }-      go HsStarTy{} = error "HsStarTy"-      go XHsType{} = error "XHsType"+      go (HsQualTy _ (L _ cons) ty') =+        m { tyHsQualTy = mAlter env vs ty' (toA (mAlter env vs cons f)) (tyHsQualTy m) }+      go HsStarTy{} = missingSyntax "HsStarTy"+      go (HsSumTy _ tys) = m { tyHsSumTy = mAlter env vs tys f (tyHsSumTy m) }+      go (HsTupleTy _ ts tys) =+        m { tyHsTupleTy = mAlter env vs ts (toA (mAlter env vs tys f)) (tyHsTupleTy m) }+      go XHsType{} = missingSyntax "XHsType" #endif-      go HsExplicitListTy{} = error "HsExplicitListTy"-      go HsExplicitTupleTy{} = error "HsExplicitTupleTy"-      go HsTyLit{} = error "HsTyLit"-      go HsWildCardTy{} = error "HsWildCardTy"-      go HsSumTy{} = error "HsSumTy"+      go HsExplicitListTy{} = missingSyntax "HsExplicitListTy"+      go HsExplicitTupleTy{} = missingSyntax "HsExplicitTupleTy"+      go HsTyLit{} = missingSyntax "HsTyLit"+      go HsWildCardTy{} = missingSyntax "HsWildCardTy" #if __GLASGOW_HASKELL__ < 808 #else-      go HsAppKindTy{} = error "HsAppKindTy"+      go HsAppKindTy{} = missingSyntax "HsAppKindTy" #endif    mMatch :: MatchEnv -> Key TyMap -> (Substitution, TyMap a) -> [(Substitution, a)]@@ -1256,13 +1306,23 @@ #if __GLASGOW_HASKELL__ < 806       go (HsAppTy ty1 ty2) = mapFor tyHsAppTy >=> mMatch env ty1 >=> mMatch env ty2       go (HsAppsTy atys) = mapFor tyHsAppsTy >=> mMatch env atys+      go (HsForAllTy bndrs ty') = mapFor tyHsForAllTy >=> mMatch env (bndrs, ty')       go (HsFunTy ty1 ty2) = mapFor tyHsFunTy >=> mMatch env ty1 >=> mMatch env ty2+      go (HsListTy ty') = mapFor tyHsListTy >=> mMatch env ty'       go (HsParTy ty') = mapFor tyHsParTy >=> mMatch env ty'+      go (HsQualTy (L _ cons) ty') = mapFor tyHsQualTy >=> mMatch env ty' >=> mMatch env cons+      go (HsSumTy tys) = mapFor tyHsSumTy >=> mMatch env tys+      go (HsTupleTy ts tys) = mapFor tyHsTupleTy >=> mMatch env ts >=> mMatch env tys       go (HsTyVar _ v) = mapFor tyHsTyVar >=> mMatch env (unLoc v) #else       go (HsAppTy _ ty1 ty2) = mapFor tyHsAppTy >=> mMatch env ty1 >=> mMatch env ty2+      go (HsForAllTy _ bndrs ty') = mapFor tyHsForAllTy >=> mMatch env (bndrs, ty')       go (HsFunTy _ ty1 ty2) = mapFor tyHsFunTy >=> mMatch env ty1 >=> mMatch env ty2+      go (HsListTy _ ty') = mapFor tyHsListTy >=> mMatch env ty'       go (HsParTy _ ty') = mapFor tyHsParTy >=> mMatch env ty'+      go (HsQualTy _ (L _ cons) ty') = mapFor tyHsQualTy >=> mMatch env ty' >=> mMatch env cons+      go (HsSumTy _ tys) = mapFor tyHsSumTy >=> mMatch env tys+      go (HsTupleTy _ ts tys) = mapFor tyHsTupleTy >=> mMatch env ts >=> mMatch env tys       go (HsTyVar _ _ v) = mapFor tyHsTyVar >=> mMatch env (unLoc v) #endif       go _                  = const [] -- TODO@@ -1303,8 +1363,10 @@   mUnion :: AppTyMap a -> AppTyMap a -> AppTyMap a   mUnion AppTyEmpty m = m   mUnion m AppTyEmpty = m-  mUnion (ATM a1 b1) (ATM a2 b2) =-    ATM (mUnion a1 a2) (mUnion b1 b2)+  mUnion m1 m2 = ATM+    { atmAppInfix = unionOn atmAppInfix m1 m2+    , atmAppPrefix = unionOn atmAppPrefix m1 m2+    }    mAlter :: AlphaEnv -> Quantifiers -> Key AppTyMap -> A a -> AppTyMap a -> AppTyMap a   mAlter env vs aty f AppTyEmpty = mAlter env vs aty f emptyAppTyMapWrapper@@ -1371,3 +1433,113 @@   where     go (L l (HsRecField (L l2 f) arg pun)) =       L l (HsRecField (L l2 (recordFieldToRdrName f)) arg pun)++------------------------------------------------------------------------++data TupleSortMap a = TupleSortMap+  { tsUnboxed :: MaybeMap a+  , tsBoxed :: MaybeMap a+  , tsConstraint :: MaybeMap a+  , tsBoxedOrConstraint :: MaybeMap a+  }+  deriving (Functor)++instance PatternMap TupleSortMap where+  type Key TupleSortMap = HsTupleSort++  mEmpty :: TupleSortMap a+  mEmpty = TupleSortMap mEmpty mEmpty mEmpty mEmpty++  mUnion :: TupleSortMap a -> TupleSortMap a -> TupleSortMap a+  mUnion m1 m2 = TupleSortMap+    { tsUnboxed = unionOn tsUnboxed m1 m2+    , tsBoxed = unionOn tsBoxed m1 m2+    , tsConstraint = unionOn tsConstraint m1 m2+    , tsBoxedOrConstraint = unionOn tsBoxedOrConstraint m1 m2+    }++  mAlter :: AlphaEnv -> Quantifiers -> Key TupleSortMap -> A a -> TupleSortMap a -> TupleSortMap a+  mAlter env vs HsUnboxedTuple f m =+    m { tsUnboxed = mAlter env vs () f (tsUnboxed m) }+  mAlter env vs HsBoxedTuple f m =+    m { tsBoxed = mAlter env vs () f (tsBoxed m) }+  mAlter env vs HsConstraintTuple f m =+    m { tsConstraint = mAlter env vs () f (tsConstraint m) }+  mAlter env vs HsBoxedOrConstraintTuple f m =+    m { tsBoxedOrConstraint = mAlter env vs () f (tsBoxedOrConstraint m) }++  mMatch :: MatchEnv -> Key TupleSortMap -> (Substitution, TupleSortMap a) -> [(Substitution, a)]+  mMatch env HsUnboxedTuple = mapFor tsUnboxed >=> mMatch env ()+  mMatch env HsBoxedTuple = mapFor tsBoxed >=> mMatch env ()+  mMatch env HsConstraintTuple = mapFor tsConstraint >=> mMatch env ()+  mMatch env HsBoxedOrConstraintTuple = mapFor tsBoxedOrConstraint >=> mMatch env ()+++------------------------------------------------------------------------++-- Note [Telescope]+-- Haskell's forall quantification is a telescope (type binders are in-scope+-- to binders to the right. Example: forall r (a :: TYPE r). ...+--+-- To support this, we peel off the binders one at a time, extending the+-- environment at each layer.++data ForAllTyMap a = ForAllTyMap+  { fatNil :: TyMap a+  , fatUser :: ForAllTyMap a+  , fatKinded :: TyMap (ForAllTyMap a)+  }+  deriving (Functor)++instance PatternMap ForAllTyMap where+  type Key ForAllTyMap = ([LHsTyVarBndr GhcPs], LHsType GhcPs)++  mEmpty :: ForAllTyMap a+  mEmpty = ForAllTyMap mEmpty mEmpty mEmpty++  mUnion :: ForAllTyMap a -> ForAllTyMap a -> ForAllTyMap a+  mUnion m1 m2 = ForAllTyMap+    { fatNil = unionOn fatNil m1 m2+    , fatUser = unionOn fatUser m1 m2+    , fatKinded = unionOn fatKinded m1 m2+    }++  mAlter :: AlphaEnv -> Quantifiers -> Key ForAllTyMap -> A a -> ForAllTyMap a -> ForAllTyMap a+  mAlter env vs ([], ty) f m = m { fatNil = mAlter env vs ty f (fatNil m) }+#if __GLASGOW_HASKELL__ < 806+  mAlter env vs (L _ (UserTyVar (L _ v)):rest, ty) f m =+#else+  mAlter env vs (L _ (UserTyVar _ (L _ v)):rest, ty) f m =+#endif+    let+      env' = extendAlphaEnvInternal v env+      vs' = vs `exceptQ` [v]+    in m { fatUser = mAlter env' vs' (rest, ty) f (fatUser m) }+#if __GLASGOW_HASKELL__ < 806+  mAlter env vs (L _ (KindedTyVar (L _ v) k):rest, ty) f m =+#else+  mAlter _ _ (L _ (XTyVarBndr _):_,_) _ _ = missingSyntax "XTyVarBndr"+  mAlter env vs (L _ (KindedTyVar _ (L _ v) k):rest, ty) f m =+#endif+    let+      env' = extendAlphaEnvInternal v env+      vs' = vs `exceptQ` [v]+    in m { fatKinded  = mAlter env vs k (toA (mAlter env' vs' (rest, ty) f)) (fatKinded m) }++  mMatch :: MatchEnv -> Key ForAllTyMap -> (Substitution, ForAllTyMap a) -> [(Substitution, a)]+  mMatch env ([],ty) = mapFor fatNil >=> mMatch env ty+#if __GLASGOW_HASKELL__ < 806+  mMatch env (L _ (UserTyVar (L _ v)):rest, ty) =+#else+  mMatch env (L _ (UserTyVar _ (L _ v)):rest, ty) =+#endif+    let env' = extendMatchEnv env [v]+    in mapFor fatUser >=> mMatch env' (rest, ty)+#if __GLASGOW_HASKELL__ < 806+  mMatch env (L _ (KindedTyVar (L _ v) k):rest, ty) =+#else+  mMatch _ (L _ (XTyVarBndr _):_,_) = const []+  mMatch env (L _ (KindedTyVar _ (L _ v) k):rest, ty) =+#endif+    let env' = extendMatchEnv env [v]+    in mapFor fatKinded >=> mMatch env k >=> mMatch env' (rest, ty)

@@ -100,8 +100,10 @@   mEmpty = UMap mEmpty mEmpty mEmpty    mUnion :: UMap a -> UMap a -> UMap a-  mUnion (UMap x1 x2 x3) (UMap y1 y2 y3) =-    UMap (mUnion x1 y1) (mUnion x2 y2) (mUnion x3 y3)+  mUnion m1 m2 = UMap+    (unionOn umExpr m1 m2)+    (unionOn umStmt m1 m2)+    (unionOn umType m1 m2)    mAlter :: AlphaEnv -> Quantifiers -> Universe -> A a -> UMap a -> UMap a   mAlter env vs u f m = go u

@@ -9,6 +9,7 @@ import Control.Applicative import Control.Concurrent.Async import Control.Exception+import Control.Monad import Data.Bifunctor (second) import Data.List import System.Exit@@ -49,61 +50,70 @@   | otherwise = mapM_ putStrLn (header:ls)  -- | Returns predicate which says whether filepath is ignored by VCS.-vcsIgnorePred :: FilePath -> IO (Maybe (FilePath -> Bool))-vcsIgnorePred fp = do-  (gitPred, hgPred) <- concurrently (gitIgnorePred fp) (hgIgnorePred fp)+vcsIgnorePred :: Verbosity -> FilePath -> IO (Maybe (FilePath -> Bool))+vcsIgnorePred verbosity fp = do+  -- We just try to run both 'git' and 'hg' here. Only one should succeed,+  -- because a directory can't be both a git repo and an hg repo.+  -- If both fail, then the whole predicate is Nothing and we keep going+  -- without ignoring any files. Not ideal, but ignoring is just a convenience+  -- to save wasted time rewriting ignored files, so not the end of the world.+  (gitPred, hgPred) <-+    concurrently (gitIgnorePred verbosity fp) (hgIgnorePred verbosity fp)   return $ gitPred <|> hgPred  -- | Read .gitignore in dir and if successful, return predicate for whether -- given repo path should be ignored.-gitIgnorePred :: FilePath -> IO (Maybe (FilePath -> Bool))-gitIgnorePred targetDir = do-  let-    cmd =-      (proc "git"-        [ "ls-files"-        , "--ignored"-        , "--exclude-standard"-        , "--others"-        , "--directory"-        , targetDir-        ])-      { cwd = Just targetDir }-  (ec, fps, _) <- readCreateProcessWithExitCode cmd ""-  case ec of-    ExitSuccess -> do-      let-        (ifiles, idirs) = partition hasExtension-          [ normalise $ targetDir </> dropTrailingPathSeparator f-          | f <- lines fps ]-      return $ Just (\fp -> fp `elem` ifiles || any (`isPrefixOf` fp) idirs)-    ExitFailure _ -> return Nothing+gitIgnorePred :: Verbosity -> FilePath -> IO (Maybe (FilePath -> Bool))+gitIgnorePred verbosity targetDir = ignoreWorker "gitIgnorePred: " verbosity targetDir id $+  proc "git"+    [ "ls-files"+    , "--ignored"+    , "--exclude-standard"+    , "--others"+    , "--directory"+    , targetDir+    ]  -- | Read .hgignore in dir and if successful, return predicate for whether -- given repo path should be ignored.-hgIgnorePred :: FilePath -> IO (Maybe (FilePath -> Bool))-hgIgnorePred targetDir = do-  let-    cmd =-      (proc "hg"-        [ "status"-        , "--ignored"-        , "--no-status"-        , "-I"-        , "re:.*\\.hs$"-        ])-      { cwd = Just targetDir }-  (ec, fps, _) <- readCreateProcessWithExitCode cmd ""+hgIgnorePred :: Verbosity -> FilePath -> IO (Maybe (FilePath -> Bool))+hgIgnorePred verbosity targetDir =+  -- .hg looks like an extension, so have to add this after the partition+  ignoreWorker "hgIgnorePred: " verbosity targetDir (normalise (targetDir </> ".hg") :) $+    proc "hg"+      [ "status"+      , "--ignored"+      , "--no-status"+      , "-I"+      , "re:.*\\.hs$"+      ]++ignoreWorker+  :: String+  -> Verbosity+  -> FilePath+  -> ([FilePath] -> [FilePath])+  -> CreateProcess+  -> IO (Maybe (FilePath -> Bool))+ignoreWorker prefix verbosity targetDir extraDirs cmd = handle (handler prefix verbosity) $ do+  let command = cmd { cwd = Just targetDir }+  (ec, fps, err) <- readCreateProcessWithExitCode command ""   case ec of     ExitSuccess -> do       let         (ifiles, dirs) = partition hasExtension           [ normalise $ targetDir </> dropTrailingPathSeparator f           | f <- lines fps ]-        -- .hg looks like an extension, so have to add this after the partition-        idirs = normalise (targetDir </> ".hg") : dirs+        idirs = extraDirs dirs       return $ Just $ \fp -> fp `elem` ifiles || any (`isPrefixOf` fp) idirs-    ExitFailure _ -> return Nothing+    ExitFailure _ -> do+      when (verbosity > Normal) $ putStrLn $ prefix ++ err+      return Nothing++handler :: String -> Verbosity -> IOError -> IO (Maybe a)+handler prefix verbosity err = do+  when (verbosity > Normal) $ putStrLn $ prefix ++ show err+  return Nothing  -- | Like 'try', but rethrows async exceptions. trySync :: IO a -> IO (Either SomeException a)

@@ -4,8 +4,10 @@ -- LICENSE file in the root directory of this source tree. -- name: retrie-version: 0.1.0.0+version: 0.1.0.1 synopsis: A powerful, easy-to-use codemodding tool for Haskell.+homepage: https://github.com/facebookincubator/retrie+bug-reports: https://github.com/facebookincubator/retrie/issues license: MIT license-file: LICENSE author: Andrew Farmer <anfarmer@fb.com>@@ -154,3 +156,7 @@     temporary,     text,     unordered-containers++source-repository head+  type:     git+  location: https://github.com/facebookincubator/retrie

@@ -43,7 +43,7 @@ hgTest :: Test hgTest = TestLabel "hg ignore" $ TestCase $   withFakeHgRepo ignoredFiles allFiles $ \repo -> do-    maybePredicate <- hgIgnorePred repo+    maybePredicate <- hgIgnorePred Loud repo     assertStuff repo maybePredicate     case maybePredicate of       Just p ->@@ -54,14 +54,14 @@ gitTest :: Test gitTest = TestLabel "git ignore" $ TestCase $   withFakeGitRepo ignoredFiles allFiles $ \repo ->-    gitIgnorePred repo >>= assertStuff repo+    gitIgnorePred Loud repo >>= assertStuff repo  unifiedTest1 :: Test unifiedTest1 = TestLabel "vcs ignore on git repo" $ TestCase $   withFakeGitRepo ignoredFiles allFiles $ \repo ->-    vcsIgnorePred repo >>= assertStuff repo+    vcsIgnorePred Loud repo >>= assertStuff repo  unifiedTest2 :: Test unifiedTest2 = TestLabel "vcs ignore on hg repo" $ TestCase $   withFakeHgRepo ignoredFiles allFiles $ \repo ->-    vcsIgnorePred repo >>= assertStuff repo+    vcsIgnorePred Loud repo >>= assertStuff repo

@@ -39,7 +39,15 @@       writeFile filePath fp  withFakeHgRepo :: [FilePath] -> [FilePath] -> (FilePath -> IO ()) -> IO ()-withFakeHgRepo = withFakeRepoCmds "hg init" ".gitignore"+withFakeHgRepo ignoredFiles allFiles f =+  withFakeRepoCmds "hg init" ".hgignore" ignoredFiles allFiles $ \dir -> do+    -- Tell 'hg' which ignore file to use for the repo, because Facebook's+    -- 'hg' looks at .gitignore by default.+    writeFile (dir </> ".hg" </> "hgrc") $ unlines+      [ "[ui]"+      , "ignore = .hgignore"+      ]+    f dir  withFakeGitRepo :: [FilePath] -> [FilePath] -> (FilePath -> IO ()) -> IO () withFakeGitRepo = withFakeRepoCmds "git init" ".gitignore"

@@ -0,0 +1,45 @@+# Copyright (c) Facebook, Inc. and its affiliates.+#+# This source code is licensed under the MIT license found in the+# LICENSE file in the root directory of this source tree.+#+--type-backward Types4.Foo+--type-backward Types4.Foo2+--type-backward Types4.Foo3+--type-backward Types4.Foo4+--type-backward Types4.Foo5+===+ {-# LANGUAGE ScopedTypeVariables #-}+ {-# LANGUAGE TypeOperators #-}+ {-# LANGUAGE UnboxedSums #-}+ module Types4 where+ + type Foo = [String]+-type Foo2 = ([String], Int)++type Foo2 = (Foo, Int)++-foo :: [String]++foo :: Foo+ foo = ["foo", "bar"]++-foo2 :: ([String], Int)++foo2 :: Foo2+ foo2 = (foo, 2)++ type Foo3 = (Functor f, Traversable t) => t (f a) -> f (t a)++-foo3 :: (Functor f, Traversable t) => t (f a) -> f (t a)++foo3 :: Foo3+ foo3 = sequence++ type Foo4 a = (# (# Int, String #) | a #)++-foo4 :: (# (# Int, String #) | Bool #)++foo4 :: Foo4 Bool+ foo4 = (# | True #)++ type Foo5 = forall r (a :: Type) (b :: TYPE r). (a -> b) -> a -> b++-foo5 :: forall s (c :: Type) (d :: TYPE s). (c -> d) -> c -> d++foo5 :: Foo5+ foo5 = ($)