[commit: ghc] wip/gadtpm: fixed the infinite loop (ca09493)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/gadtpm
Link       : http://ghc.haskell.org/trac/ghc/changeset/ca0949385cbd16f891e5c107f4ccbf042f518ea3/ghc

>---------------------------------------------------------------

commit ca0949385cbd16f891e5c107f4ccbf042f518ea3
Author: George Karachalias <george.karachalias at gmail.com>
Date:   Wed Oct 14 14:12:47 2015 +0200

    fixed the infinite loop


>---------------------------------------------------------------

ca0949385cbd16f891e5c107f4ccbf042f518ea3
 compiler/deSugar/Check.hs    | 12 ++++++++----
 compiler/deSugar/TmOracle.hs | 24 ++++++++++++++++++------
 2 files changed, 26 insertions(+), 10 deletions(-)

diff --git a/compiler/deSugar/Check.hs b/compiler/deSugar/Check.hs
index d08d0ce..09f4ea3 100644
--- a/compiler/deSugar/Check.hs
+++ b/compiler/deSugar/Check.hs
@@ -278,8 +278,12 @@ translatePat pat = case pat of
 
   -- overloaded list
   ListPat lpats elem_ty (Just (pat_ty, to_list))
-    | Just e_ty <- splitListTyConApp_maybe pat_ty ->
-        translatePat (ListPat lpats e_ty Nothing) -- ensure that e_ty and elem_ty are the same?? (check OverlappingInstances)
+    | Just e_ty <- splitListTyConApp_maybe pat_ty, elem_ty `eqType` e_ty ->
+        -- Watch out for horrible hack: See Note [Comparison with OpenTypeKind]
+        -- We have to ensure that the element types are the same. Otherwise, one
+        -- may give an instance IsList [Int] (more specific than the default IsList [a])
+        -- with a different implementation for `toList'
+        translatePat (ListPat lpats e_ty Nothing)
     | otherwise -> do
         (xp, xe) <- mkPmId2FormsSM pat_ty
         ps       <- translatePatVec (map unLoc lpats) -- list as value abstraction
@@ -815,7 +819,7 @@ pruneValSetAbsBound n v = fst <$> pruneValSetAbsBound' n init_cs v
                       False -> return (Empty, n)
               Nothing -> return (Empty, n)
           Cons va vsa -> do
-            (vsa', m) <- pruneValSetAbsBound' n all_cs in_vsa
+            (vsa', m) <- pruneValSetAbsBound' n all_cs vsa
             return (mkCons va vsa', m)
 
 mergeBotCs :: Maybe Id -> Maybe Id -> Maybe Id
@@ -856,7 +860,7 @@ pruneValSetAbsBoundVec n v = fst <$> pruneValSetAbsBoundVec' n init_cs emptylist
                       True  -> pruneValSetAbsBoundVec' n (new_ty_cs++ty_cs, new_tm_env, bot) vec vsa
                       False -> return ([], n)
               Nothing -> return ([], n)
-          Cons va vsa -> pruneValSetAbsBoundVec' n all_cs (vec `snoc` va) in_vsa
+          Cons va vsa -> pruneValSetAbsBoundVec' n all_cs (vec `snoc` va) vsa
 
 isNotEmpty :: ValSetAbs -> Bool
 isNotEmpty Empty = False
diff --git a/compiler/deSugar/TmOracle.hs b/compiler/deSugar/TmOracle.hs
index 9d6adec..fbd2b4d 100644
--- a/compiler/deSugar/TmOracle.hs
+++ b/compiler/deSugar/TmOracle.hs
@@ -374,12 +374,14 @@ solveComplexEqIncr solver_state@(standby, (unhandled, env)) eq@(e1, e2) = case e
     | x == y    -> Just solver_state
     | otherwise -> extendSubstAndSolve x e2 solver_state {- CHOOSE ONE AND EXTEND SUBST & LOOK AT STB -}
 
-  (PmExprVar x, PmExprCon {}) -> extendSubstAndSolve x e2 solver_state {- EXTEND SUBST & LOOK AT STB -}
-  (PmExprCon {}, PmExprVar x) -> extendSubstAndSolve x e1 solver_state {- EXTEND SUBST & LOOK AT STB -}
-  (PmExprVar x, PmExprLit {}) -> extendSubstAndSolve x e2 solver_state {- EXTEND SUBST & LOOK AT STB -}
-  (PmExprLit {}, PmExprVar x) -> extendSubstAndSolve x e1 solver_state {- EXTEND SUBST & LOOK AT STB -}
-  (PmExprVar x,  PmExprEq {}) -> extendSubstAndSolve x e2 solver_state {- EXTEND SUBST & LOOK AT STB -}
-  (PmExprEq  {}, PmExprVar x) -> extendSubstAndSolve x e1 solver_state {- EXTEND SUBST & LOOK AT STB -}
+  (PmExprVar x, _) -> extendSubstAndSolve x e2 solver_state {- EXTEND SUBST & LOOK AT STB -}
+  (_, PmExprVar x) -> extendSubstAndSolve x e1 solver_state {- EXTEND SUBST & LOOK AT STB -}
+  -- (PmExprVar x, PmExprCon {}) -> extendSubstAndSolve x e2 solver_state {- EXTEND SUBST & LOOK AT STB -}
+  -- (PmExprCon {}, PmExprVar x) -> extendSubstAndSolve x e1 solver_state {- EXTEND SUBST & LOOK AT STB -}
+  -- (PmExprVar x, PmExprLit {}) -> extendSubstAndSolve x e2 solver_state {- EXTEND SUBST & LOOK AT STB -}
+  -- (PmExprLit {}, PmExprVar x) -> extendSubstAndSolve x e1 solver_state {- EXTEND SUBST & LOOK AT STB -}
+  -- (PmExprVar x,  PmExprEq {}) -> extendSubstAndSolve x e2 solver_state {- EXTEND SUBST & LOOK AT STB -}
+  -- (PmExprEq  {}, PmExprVar x) -> extendSubstAndSolve x e1 solver_state {- EXTEND SUBST & LOOK AT STB -}
 
   (PmExprEq _ _, PmExprEq _ _) -> Just (eq:standby, (unhandled, env))
 
@@ -421,6 +423,10 @@ simplifyEqExpr e1 e2 = case (e1, e2) of
     ((e1', True ), (e2', _    )) -> simplifyEqExpr e1' e2'
     ((e1', _    ), (e2', True )) -> simplifyEqExpr e1' e2'
     ((e1', False), (e2', False)) -> (PmExprEq e1' e2', False) -- cannot go further
+  (_, PmExprEq {}) -> case (simplifyPmExpr e1, simplifyPmExpr e2) of
+    ((e1', True ), (e2', _    )) -> simplifyEqExpr e1' e2'
+    ((e1', _    ), (e2', True )) -> simplifyEqExpr e1' e2'
+    ((e1', False), (e2', False)) -> (PmExprEq e1' e2', False) -- cannot go further
 
   -- Constructors
   (PmExprCon c1 ts1, PmExprCon c2 ts2) -- constructors
@@ -463,6 +469,12 @@ exprDeepLookup _   other_expr       = other_expr -- lit ==> lit, expr_other ==>
 tmOracleIncr :: IncrState -> [SimpleEq] -> Maybe IncrState
 tmOracleIncr env eqs = foldlM solveSimpleEqIncr env eqs
 
+-- -- let's see what this can do
+-- tmOracle :: [SimpleEq] -> Either Failure ([ComplexEq], TmOracleEnv)
+-- tmOracle eqs = case tmOracleIncr initialIncrState eqs of
+--   Nothing -> Left undefined
+--   Just x  -> Right x
+
 -- ----------------------------------------------------------------------------
 
 -- Should be in PmExpr gives cyclic imports :(