[commit: ghc] wip/gadtpm: Make hsExprToPmExpr look through HsWrap (bugfix) (011ad88)
git at git.haskell.org
git at git.haskell.org
Sun Oct 18 17:52:31 UTC 2015
Repository : ssh://git@git.haskell.org/ghc
On branch : wip/gadtpm
Link : http://ghc.haskell.org/trac/ghc/changeset/011ad88fde052f4d9c7f3ab8ea378e4fb9c60591/ghc
>---------------------------------------------------------------
commit 011ad88fde052f4d9c7f3ab8ea378e4fb9c60591
Author: George Karachalias <george.karachalias at gmail.com>
Date: Sun Oct 18 19:51:04 2015 +0200
Make hsExprToPmExpr look through HsWrap (bugfix)
>---------------------------------------------------------------
011ad88fde052f4d9c7f3ab8ea378e4fb9c60591
compiler/deSugar/Check.hs | 12 +++---------
compiler/deSugar/PmExpr.hs | 2 +-
compiler/deSugar/TmOracle.hs | 37 ++++---------------------------------
compiler/typecheck/TcRnTypes.hs | 6 +-----
4 files changed, 9 insertions(+), 48 deletions(-)
diff --git a/compiler/deSugar/Check.hs b/compiler/deSugar/Check.hs
index 84515d3..fb02ecb 100644
--- a/compiler/deSugar/Check.hs
+++ b/compiler/deSugar/Check.hs
@@ -52,8 +52,6 @@ import Data.List -- find
import Data.Maybe -- isNothing, isJust, fromJust
import Control.Monad -- liftM3, forM
-import TcRnTypes ( pprInTcRnIf, pprSDocUnsafeAnd )
-
{-
This module checks pattern matches for:
\begin{enumerate}
@@ -290,7 +288,7 @@ translatePat pat = case pat of
(xp, xe) <- mkPmId2FormsSM pat_ty
ps <- translatePatVec (map unLoc lpats) -- list as value abstraction
let pats = foldr (mkListPatVec elem_ty) [nilPattern elem_ty] ps
- g = mkGuard pats (HsApp (noLoc to_list) xe) -- [...] <- toList x
+ g = mkGuard pats (HsApp (noLoc to_list) xe) -- [...] <- toList x -- THIS IS WRONG
return [xp,g]
ConPatOut { pat_con = L _ (PatSynCon _) } -> do
@@ -956,12 +954,8 @@ pmTraverse us gvsa rec (p:ps) vsa =
let (us1, us2) = splitUniqSupply us
y = mkPmId us1 (patternType p)
cs = [TmConstraint y e]
- (message, new_cs) = case isPmExprOtherWithVar e of
- Nothing -> (empty, cs)
- Just e' -> ((ptext (sLit "pmTraverse: needs fixing:") <+> (ppr y <+> ptext (sLit "=||=") <+> ppr e)) $$ (ptext (sLit "Fixed?:") <+> (ppr y <+> ptext (sLit "=||=") <+> ppr e') ), [TmConstraint y e'])
-
- in message -- (ptext (sLit "pmTraverse: Adding constraint:") <+> ppr y <+> ptext (sLit "=||=") <+> ppr e)
- `pprSDocUnsafeAnd` (mkConstraint new_cs $ tailValSetAbs $ pmTraverse us2 gvsa rec (pv++ps) (VA (PmVar y) `mkCons` vsa))
+ in mkConstraint cs $ tailValSetAbs $
+ pmTraverse us2 gvsa rec (pv++ps) (VA (PmVar y) `mkCons` vsa)
-- Constructor/Variable/Literal Case
NonGuard pat
diff --git a/compiler/deSugar/PmExpr.hs b/compiler/deSugar/PmExpr.hs
index 19f8719..8e38522 100644
--- a/compiler/deSugar/PmExpr.hs
+++ b/compiler/deSugar/PmExpr.hs
@@ -217,7 +217,7 @@ hsExprToPmExpr (HsSCC _ e) = lhsExprToPmExpr e
hsExprToPmExpr (HsCoreAnn _ e) = lhsExprToPmExpr e
hsExprToPmExpr (ExprWithTySig e _ _) = lhsExprToPmExpr e
hsExprToPmExpr (ExprWithTySigOut e _) = lhsExprToPmExpr e
-
+hsExprToPmExpr (HsWrap _ e) = hsExprToPmExpr e -- DROP THE DAMN WRAPPER
hsExprToPmExpr e = PmExprOther e -- the rest are not handled by the oracle
{-
diff --git a/compiler/deSugar/TmOracle.hs b/compiler/deSugar/TmOracle.hs
index 104d019..bbae621 100644
--- a/compiler/deSugar/TmOracle.hs
+++ b/compiler/deSugar/TmOracle.hs
@@ -17,10 +17,7 @@ module TmOracle (
tmOracle, TmState, initialTmState,
-- misc.
- exprDeepLookup, pmLitType, flattenPmVarEnv,
-
- -- DEBUGGING
- isPmExprOtherWithVar
+ exprDeepLookup, pmLitType, flattenPmVarEnv
) where
#include "HsVersions.h"
@@ -40,11 +37,6 @@ import Util
import qualified Data.Map as Map
import Data.Maybe
--- still debugging
-import TcRnTypes (pprSDocUnsafeAnd)
-import System.IO.Unsafe (unsafePerformIO)
-import HsSyn
-
{-
%************************************************************************
%* *
@@ -114,10 +106,8 @@ solveComplexEq solver_state@(standby, (unhandled, env)) eq@(e1, e2) = case eq of
| c == falseDataCon -> Just (eq:standby, (unhandled, env))
(PmExprVar x, PmExprVar y)
- | x == y -> (unsafePerformIO . putStrLn . ("deemed equal: "++) . showSDocSimple) (ppr x <+> ptext (sLit "and") <+> ppr y)
- `seq` Just solver_state
-
- | otherwise -> ASSERT (isNothing (Map.lookup x env) && isNothing (Map.lookup y env)) extendSubstAndSolve x e2 solver_state {- CHOOSE ONE AND EXTEND SUBST & LOOK AT STB -}
+ | x == y -> Just solver_state
+ | otherwise -> extendSubstAndSolve x e2 solver_state {- CHOOSE ONE AND 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 -}
@@ -213,26 +203,7 @@ exprDeepLookup _ other_expr = other_expr -- lit ==> lit, expr_other ==>
-- | External interface to the solver
-- ----------------------------------------------------------------------------
tmOracle :: TmState -> [SimpleEq] -> Maybe TmState
-tmOracle env eqs = foldlM solveSimpleEqWithShow env eqs
- where
- solveSimpleEqWithShow :: TmState -> SimpleEq -> Maybe TmState
- solveSimpleEqWithShow s@(_,(_,subst)) eq@(var, expr)
- = let eq_str = showSDocSimple (ppr eq)
- subst_str = showSDocSimple (ppr subst)
- message_1 = "InitSubst : " ++ subst_str ++ "\n"
- ++ "Processing: " ++ eq_str -- PRINT THE ORIGINAL THOUGH
- mb_result = solveSimpleEq s eq' -- USE THE **HOPE-FIXED** ONE
- (string, eq') = case isPmExprOtherWithVar expr of
- Nothing -> (empty, eq)
- Just y -> (ptext (sLit "GOT TRASH:") <+> ppr eq <+> ptext (sLit "is it fixed now?:") <+> ppr (var, y), (var, y))
- in string `pprSDocUnsafeAnd`
- case mb_result of
- Nothing -> unsafePerformIO (putStrLn message_1 >> putStrLn "Fails") `seq` mb_result
- Just (_,(_,subst')) -> unsafePerformIO (putStrLn message_1 >> putStrLn ("Gives: " ++ showSDocSimple (ppr subst'))) `seq` mb_result
-
-isPmExprOtherWithVar :: PmExpr -> Maybe PmExpr
-isPmExprOtherWithVar (PmExprOther (HsVar x)) = Just (PmExprVar x)
-isPmExprOtherWithVar _ = Nothing
+tmOracle = foldlM solveSimpleEq
-- ----------------------------------------------------------------------------
diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs
index f40ffbb..32d78ad 100644
--- a/compiler/typecheck/TcRnTypes.hs
+++ b/compiler/typecheck/TcRnTypes.hs
@@ -92,7 +92,7 @@ module TcRnTypes(
pprArising, pprArisingAt,
-- Debugging
- pprInTcRnIf, pprSDocUnsafeAnd,
+ pprInTcRnIf,
-- Misc other types
TcId, TcIdSet, HoleSort(..)
@@ -2243,7 +2243,3 @@ pprInTcRnIf :: SDoc -> TcRnIf gbl lcl ()
pprInTcRnIf doc = do
dflags <- getDynFlags
liftIO (putStrLn (showSDoc dflags doc))
-
-pprSDocUnsafeAnd :: SDoc -> a -> a
-pprSDocUnsafeAnd doc x = unsafePerformIO (putStrLn (showSDocSimple doc)) `seq` x
-
More information about the ghc-commits
mailing list