Refactor pattern matches for ghc 8.6.

GHC's pattern match checker seems two regressions in ghc 8.6:

1. In some cases it will hang for several minutes (forever), which was
   previously fixed by limiting its iterations. Here we fix this by
   desugaring complex matches. Example:

       case (a, b) of
         (Some SObject{} a', Some SObject{} b') -> ...
         (_                , _                ) -> throwError' ...

   becomes

       case a of
         Some SObject{} a' -> case b of
           Some SObject{} b' -> ...
           _                 -> throwError' ...
         _ -> throwError' ...

2. In some cases it erroneously decides a match is redundant (for
   example in the before example above). This has the same fix.

Tested by `stack test` and `cabal test`.

cabal.project

@@ -4,7 +4,7 @@ packages:
 allow-newer: pact:all
 
 package pact
-    ghc-options: -Wwarn -Wall -fmax-pmcheck-iterations=1000
+    ghc-options: -Wwarn -Wall
 
 source-repository-package
     type: git

src/Pact/Analyze/Translate.hs

@@ -982,28 +982,35 @@ translateNode astNode = withAstContext astNode $ case astNode of
   AST_NFun_Basic fn@(toOp comparisonOpP -> Just op) args@[a, b] -> do
     aT <- translateNode a
     bT <- translateNode b
-    case (aT, bT) of
 
-      (Some (SList SAny) EmptyList, Some (SList ty) lst) -> do
-        op' <- toOp eqNeqP fn ?? MalformedComparison fn args
-        pure $ Some SBool $ CoreTerm $ ListEqNeq ty op' EmptyList lst
-
-      (Some (SList ty) lst, Some (SList SAny) EmptyList) -> do
-        op' <- toOp eqNeqP fn ?? MalformedComparison fn args
-        pure $ Some SBool $ CoreTerm $ ListEqNeq ty op' lst EmptyList
-
-      (Some (SList ta) a', Some (SList tb) b') -> do
-        Refl <- singEq ta tb ?? TypeMismatch (EType ta) (EType tb)
-        op'  <- toOp eqNeqP fn ?? MalformedComparison fn args
-        pure $ Some SBool $ inject $ ListEqNeq ta op' a' b'
-
-      (Some ta@SObject{} a', Some tb@SObject{} b') -> do
-        op' <- toOp eqNeqP fn ?? MalformedComparison fn args
-        pure $ Some SBool $ inject $ ObjectEqNeq ta tb op' a' b'
-
-      (Some ta a', Some tb b') -> do
-        Refl <- singEq ta tb ?? TypeMismatch (EType ta) (EType tb)
-        pure $ Some SBool $ inject $ Comparison ta op a' b'
+    case aT of
+      Some tyA@(SList SAny) EmptyList -> case bT of
+        Some (SList ty) lst -> do
+          op' <- toOp eqNeqP fn ?? MalformedComparison fn args
+          pure $ Some SBool $ CoreTerm $ ListEqNeq ty op' EmptyList lst
+        Some tyB _ -> throwError' $ TypeMismatch (EType tyA) (EType tyB)
+
+      Some (SList ta) a' -> case bT of
+        Some (SList SAny) EmptyList -> do
+          op' <- toOp eqNeqP fn ?? MalformedComparison fn args
+          pure $ Some SBool $ CoreTerm $ ListEqNeq ta op' a' EmptyList
+        Some (SList tb) b' -> do
+          Refl <- singEq ta tb ?? TypeMismatch (EType ta) (EType tb)
+          op'  <- toOp eqNeqP fn ?? MalformedComparison fn args
+          pure $ Some SBool $ inject $ ListEqNeq ta op' a' b'
+        Some tb _ -> throwError' $ TypeMismatch (EType (SList ta)) (EType tb)
+
+      Some ta@SObject{} a' -> case bT of
+        Some tb b' -> case tb of
+          SObject{} -> do
+            op' <- toOp eqNeqP fn ?? MalformedComparison fn args
+            pure $ Some SBool $ inject $ ObjectEqNeq ta tb op' a' b'
+          _ -> throwError' $ TypeMismatch (EType ta) (EType tb)
+
+      Some ta a' -> case bT of
+        Some tb b' -> do
+          Refl <- singEq ta tb ?? TypeMismatch (EType ta) (EType tb)
+          pure $ Some SBool $ inject $ Comparison ta op a' b'
 
   AST_NFun_Basic fn@(toOp comparisonOpP -> Just _) args
     -> throwError' $ MalformedComparison fn args
@@ -1063,26 +1070,38 @@ translateNode astNode = withAstContext astNode $ case astNode of
   --
   AST_NFun node fn@"+" args@[a, b] -> do
     EType retTy <- translateType node
-    aT          <- translateNode a
-    bT          <- translateNode b
-    case (aT, bT) of
-      (Some ty1@SObject{} o1, Some ty2@SObject{} o2) -> do
-        -- Feature 3: object merge
-        pure $ Some retTy $ inject $ ObjMerge ty1 ty2 o1 o2
-      (Some (SList tyA) a', Some (SList tyB) b') -> do
-        Refl <- singEq tyA tyB ?? MalformedArithOp fn args
-        -- Feature 4: list concatenation
-        pure $ Some (SList tyA) $ inject $ ListConcat tyA a' b'
-      (Some tyA a', Some tyB b') ->
-        case (tyA, tyB) of
-          -- Feature 1: string concatenation
-          (SStr, SStr)         -> pure $ Some SStr $ inject $ StrConcat a' b'
-          -- Feature 2: arithmetic addition
-          (SInteger, SInteger) -> pure $ Some SInteger $ inject $ IntArithOp Add a' b'
-          (SDecimal, SDecimal) -> pure $ Some SDecimal $ inject $ DecArithOp Add a' b'
-          (SInteger, SDecimal) -> pure $ Some SDecimal $ inject $ IntDecArithOp Add a' b'
-          (SDecimal, SInteger) -> pure $ Some SDecimal $ inject $ DecIntArithOp Add a' b'
-          _ -> throwError' $ MalformedArithOp fn args
+    Some tyA a' <- translateNode a
+    Some tyB b' <- translateNode b
+
+    case tyA of
+      SObject{} -> case tyB of
+        SObject{} -> do
+          -- Feature 3: object merge
+          pure $ Some retTy $ inject $ ObjMerge tyA tyB a' b'
+        _ -> throwError' $ TypeMismatch (EType tyA) (EType tyB)
+
+      SList tyElemA -> case tyB of
+        SList tyElemB -> do
+          Refl <- singEq tyElemA tyElemB ?? MalformedArithOp fn args
+          -- Feature 4: list concatenation
+          pure $ Some (SList tyElemA) $ inject $ ListConcat tyElemA a' b'
+
+        _ -> throwError' $ TypeMismatch (EType tyA) (EType tyB)
+
+      -- Feature 1: string concatenation
+      SStr -> case tyB of
+        SStr -> pure $ Some SStr $ inject $ StrConcat a' b'
+        _    -> throwError' $ TypeMismatch (EType tyA) (EType tyB)
+      -- Feature 2: arithmetic addition
+      SInteger -> case tyB of
+        SInteger -> pure $ Some SInteger $ inject $ IntArithOp    Add a' b'
+        SDecimal -> pure $ Some SDecimal $ inject $ IntDecArithOp Add a' b'
+        _        -> throwError' $ TypeMismatch (EType tyA) (EType tyB)
+      SDecimal -> case tyB of
+        SDecimal -> pure $ Some SDecimal $ inject $ DecArithOp    Add a' b'
+        SInteger -> pure $ Some SDecimal $ inject $ DecIntArithOp Add a' b'
+        _        -> throwError' $ TypeMismatch (EType tyA) (EType tyB)
+      _ -> throwError' $ MalformedArithOp fn args
 
   AST_NFun_Basic fn@(toOp arithOpP -> Just op) args@[a, b] -> do
       Some tyA a' <- translateNode a
@@ -1239,15 +1258,16 @@ translateNode astNode = withAstContext astNode $ case astNode of
             (Read tableObjTy Nothing tid (TableName (T.unpack table)) key')
 
   AST_At node index obj -> do
-    obj'     <- translateNode obj
-    EType ty <- translateType node
-    case obj' of
-      Some objTy@SObject{} obj'' -> do
+    Some objTy obj' <- translateNode obj
+    EType ty        <- translateType node
+
+    case objTy of
+      SObject schema -> do
         Some SStr colName <- translateNode index
-        pure $ Some ty $ CoreTerm $ ObjAt objTy colName obj''
-      Some (SList listOfTy) list -> do
+        pure $ Some ty $ CoreTerm $ ObjAt (SObjectUnsafe schema) colName obj'
+      SList listOfTy -> do
         Some SInteger index' <- translateNode index
-        pure $ Some listOfTy $ CoreTerm $ ListAt listOfTy index' list
+        pure $ Some listOfTy $ CoreTerm $ ListAt listOfTy index' obj'
       _ -> throwError' $ TypeError node
 
   AST_Obj _node (Pact.ObjectMap kvs) -> do

stack.yaml

@@ -5,12 +5,8 @@ resolver: lts-13.19
 packages:
   - '.'
 
-# GHC 8.6 has a more aggressive Pattern Match exhaustion checker. A number of
-# Pact's `Analysis` modules cause seeming infinite loops in the compiler during
-# this analysis, so here we limit the depth to 5000, then override `-Werror`
-# with `-Wwarn` to avoid failing the build.
 ghc-options:
-  pact: -fmax-pmcheck-iterations=5000 -Wwarn
+  pact: -Wwarn -Wall
 
 extra-deps:
   # --- Missing from Stackage --- #