Merge in more HEAD, fix stuff up
authorSimon Peyton Jones <simonpj@microsoft.com>
Mon, 23 Jan 2012 12:12:11 +0000 (12:12 +0000)
committerSimon Peyton Jones <simonpj@microsoft.com>
Mon, 23 Jan 2012 12:12:11 +0000 (12:12 +0000)
18 files changed:
1  2 
compiler/coreSyn/CoreLint.lhs
compiler/deSugar/DsBinds.lhs
compiler/iface/TcIface.lhs
compiler/parser/Parser.y.pp
compiler/parser/RdrHsSyn.lhs
compiler/prelude/PrelNames.lhs
compiler/stgSyn/StgLint.lhs
compiler/typecheck/TcCanonical.lhs
compiler/typecheck/TcErrors.lhs
compiler/typecheck/TcEvidence.lhs
compiler/typecheck/TcForeign.lhs
compiler/typecheck/TcHsSyn.lhs
compiler/typecheck/TcInteract.lhs
compiler/typecheck/TcMType.lhs
compiler/typecheck/TcSimplify.lhs
compiler/typecheck/TcSplice.lhs
compiler/typecheck/TcType.lhs
compiler/typecheck/TcUnify.lhs

Simple merge
@@@ -32,7 -32,7 +32,8 @@@ import DsUtil
  
  import HsSyn          -- lots of things
  import CoreSyn                -- lots of things
- import HscTypes(MonadThings)
++import HscTypes         ( MonadThings )
+ import Literal          ( Literal(MachStr) )
  import CoreSubst
  import MkCore
  import CoreUtils
@@@ -709,12 -704,13 +711,16 @@@ dsEvTerm (EvTupleMk vs) = return $ Var 
    where dc = tupleCon ConstraintTuple (length vs)
          tys = map varType vs
  dsEvTerm (EvSuperClass d n)
 -  = Var sc_sel_id `mkTyApps` tys `App` Var d
 +  = return $ Var sc_sel_id `mkTyApps` tys `App` Var d
    where
      sc_sel_id  = classSCSelId cls n   -- Zero-indexed
-     (cls, tys) = getClassPredTys (evVarPred d)    
+     (cls, tys) = getClassPredTys (evVarPred d)   
 -dsEvTerm (EvDelayedError ty msg) = Var errorId `mkTyApps` [ty] `mkApps` [litMsg]
 -  where errorId = rUNTIME_ERROR_ID
 -        litMsg  = Lit (MachStr msg)
++dsEvTerm (EvDelayedError ty msg) = return $ Var errorId `mkTyApps` [ty] `mkApps` [litMsg]
++  where 
++    errorId = rUNTIME_ERROR_ID
++    litMsg  = Lit (MachStr msg)
 +
 +dsEvTerm (EvInteger n) = mkIntegerExpr n
  
  ---------------------------------------
  dsTcCoercion :: TcCoercion -> (Coercion -> CoreExpr) -> CoreExpr
Simple merge
@@@ -472,17 -471,14 +472,17 @@@ exp_doc :: { LIE RdrName 
     -- No longer allow things like [] and (,,,) to be exported
     -- They are built in syntax, always available
  export  :: { LIE RdrName }
 -        :  qvar                         { L1 (IEVar (unLoc $1)) }
 -        |  oqtycon                      { L1 (IEThingAbs (unLoc $1)) }
 -        |  oqtycon '(' '..' ')'         { LL (IEThingAll (unLoc $1)) }
 -        |  oqtycon '(' ')'              { LL (IEThingWith (unLoc $1) []) }
 -        |  oqtycon '(' qcnames ')'      { LL (IEThingWith (unLoc $1) (reverse $3)) }
 +        : qcname_ext export_subspec     { LL (mkModuleImpExp (unLoc $1)
 +                                                             (unLoc $2)) }
          |  'module' modid               { LL (IEModuleContents (unLoc $2)) }
  
 -qcnames :: { [RdrName] }
 +export_subspec :: { Located ImpExpSubSpec }
 +        : {- empty -}                   { L0 ImpExpAbs }
 +        | '(' '..' ')'                  { LL ImpExpAll }
 +        | '(' ')'                       { LL (ImpExpList []) }
-         | '(' qcnames ')'               { LL (ImpExpList $2) }
++        | '(' qcnames ')'               { LL (ImpExpList (reverse $2)) }
 +
- qcnames :: { [RdrName] }
++qcnames :: { [RdrName] }     -- A reversed list
          :  qcnames ',' qcname_ext       { unLoc $3 : $1 }
          |  qcname_ext                   { [unLoc $1]  }
  
@@@ -987,24 -979,6 +987,24 @@@ mkExtName :: RdrName -> CLabelStrin
  mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm))
  \end{code}
  
-     ImpExpAbs | isVarNameSpace (rdrNameSpace name)
-                   -> IEVar       name
-     ImpExpAbs     -> IEThingAbs  nameT
-     ImpExpAll     -> IEThingAll  nameT
-     ImpExpList xs -> IEThingWith nameT xs
 +--------------------------------------------------------------------------------
 +-- Help with module system imports/exports
 +
 +\begin{code}
 +data ImpExpSubSpec = ImpExpAbs | ImpExpAll | ImpExpList [ RdrName ]
 +
 +mkModuleImpExp :: RdrName -> ImpExpSubSpec -> IE RdrName
 +mkModuleImpExp name subs =
 +  case subs of
-   nameT = setRdrNameSpace name tcClsName
++    ImpExpAbs 
++      | isVarNameSpace (rdrNameSpace name) -> IEVar       name
++      | otherwise                          -> IEThingAbs  nameT
++    ImpExpAll                              -> IEThingAll  nameT
++    ImpExpList xs                          -> IEThingWith nameT xs
 +
 +  where
++    nameT = setRdrNameSpace name tcClsName
 +\end{code}
  
  -----------------------------------------------------------------------------
  -- Misc utils
Simple merge
@@@ -391,8 -398,8 +391,8 @@@ checkFunApp fun_ty arg_tys ms
   where
    (mb_ty, mb_msg) = cfa True fun_ty arg_tys
  
-   cfa :: Bool -> Type -> [Type] -> (Maybe Type        -- Accurate result?
-                                    , Maybe Message)   -- Errors?
 -  cfa :: Bool -> Type -> [Type] -> (Maybe Type                -- Accurate result?
 -                                   , Maybe MsgDoc)    -- Errors?
++  cfa :: Bool -> Type -> [Type] -> (Maybe Type       -- Accurate result?
++                                   , Maybe MsgDoc)   -- Errors?
  
    cfa accurate fun_ty []      -- Args have run out; that's fine
        = (if accurate then Just fun_ty else Nothing, Nothing)
Simple merge
Simple merge
@@@ -559,14 -527,14 +563,15 @@@ isEmptyTcEvBinds (TcEvBinds {}) = pani
  \r
  evVarsOfTerm :: EvTerm -> [EvVar]\r
  evVarsOfTerm (EvId v) = [v]\r
- evVarsOfTerm (EvCoercion co)     = varSetElems (coVarsOfTcCo co)\r
- evVarsOfTerm (EvDFunApp _ _ evs) = evs\r
- evVarsOfTerm (EvTupleSel v _)    = [v]\r
- evVarsOfTerm (EvSuperClass v _)  = [v]\r
- evVarsOfTerm (EvCast v co)       = v : varSetElems (coVarsOfTcCo co)\r
- evVarsOfTerm (EvTupleMk evs)     = evs\r
+ evVarsOfTerm (EvCoercion co)      = varSetElems (coVarsOfTcCo co)\r
+ evVarsOfTerm (EvDFunApp _ _ evs)  = evs\r
+ evVarsOfTerm (EvTupleSel v _)     = [v]\r
+ evVarsOfTerm (EvSuperClass v _)   = [v]\r
+ evVarsOfTerm (EvCast v co)        = v : varSetElems (coVarsOfTcCo co)\r
+ evVarsOfTerm (EvTupleMk evs)      = evs\r
+ evVarsOfTerm (EvDelayedError _ _) = []\r
  evVarsOfTerm (EvKindCast v co)   = v : varSetElems (coVarsOfTcCo co)\r
 +evVarsOfTerm (EvInteger _)       = []\r
  \end{code}\r
  \r
  \r
@@@ -618,14 -586,15 +623,16 @@@ instance Outputable EvBind wher
     -- We cheat a bit and pretend EqVars are CoVars for the purposes of pretty printing\r
  \r
  instance Outputable EvTerm where\r
--  ppr (EvId v)           = ppr v\r
--  ppr (EvCast v co)      = ppr v <+> (ptext (sLit "`cast`")) <+> pprParendTcCo co\r
--  ppr (EvKindCast v co)  = ppr v <+> (ptext (sLit "`kind-cast`")) <+> pprParendTcCo co\r
--  ppr (EvCoercion co)    = ptext (sLit "CO") <+> ppr co\r
--  ppr (EvTupleSel v n)   = ptext (sLit "tupsel") <> parens (ppr (v,n))\r
--  ppr (EvTupleMk vs)     = ptext (sLit "tupmk") <+> ppr vs\r
--  ppr (EvSuperClass d n) = ptext (sLit "sc") <> parens (ppr (d,n))\r
--  ppr (EvDFunApp df tys ts) = ppr df <+> sep [ char '@' <> ppr tys, ppr ts ]\r
-   ppr (EvInteger n)      = integer n\r
 -  ppr (EvDelayedError ty msg) =     ptext (sLit "error") \r
++  ppr (EvId v)                = ppr v\r
++  ppr (EvCast v co)           = ppr v <+> (ptext (sLit "`cast`")) <+> pprParendTcCo co\r
++  ppr (EvKindCast v co)       = ppr v <+> (ptext (sLit "`kind-cast`")) <+> pprParendTcCo co\r
++  ppr (EvCoercion co)         = ptext (sLit "CO") <+> ppr co\r
++  ppr (EvTupleSel v n)        = ptext (sLit "tupsel") <> parens (ppr (v,n))\r
++  ppr (EvTupleMk vs)          = ptext (sLit "tupmk") <+> ppr vs\r
++  ppr (EvSuperClass d n)      = ptext (sLit "sc") <> parens (ppr (d,n))\r
++  ppr (EvDFunApp df tys ts)   = ppr df <+> sep [ char '@' <> ppr tys, ppr ts ]\r
++  ppr (EvInteger n)           = integer n\r
++  ppr (EvDelayedError ty msg) = ptext (sLit "error") \r
+                                 <+> sep [ char '@' <> ppr ty, ppr msg ]\r
  \end{code}\r
  \r
Simple merge
Simple merge
@@@ -1764,15 -1761,9 +1762,15 @@@ NB: The desugarer needs be more clever 
  \begin{code}
  data LookupInstResult
    = NoInstance
-   | GenInst [WantedEvVar] EvTerm 
+   | GenInst [EvVar] EvTerm 
  
  matchClassInst :: InertSet -> Class -> [Type] -> WantedLoc -> TcS LookupInstResult
 +
 +matchClassInst _ clas [ ty ] _
 +  | className clas == typeNatClassName
 +  , Just n <- isNumberTy ty = return (GenInst [] (EvInteger n))
 +
 +
  matchClassInst inerts clas tys loc
     = do { let pred = mkClassPred clas tys 
          ; mb_result <- matchClass clas tys
Simple merge
Simple merge
Simple merge
@@@ -521,6 -528,17 +530,18 @@@ tidyTypes :: TidyEnv -> [Type] -> [Type
  tidyTypes env tys = map (tidyType env) tys
  
  ---------------
+ tidyType :: TidyEnv -> Type -> Type
++tidyType _   (LitTy n)            = LitTy n
+ tidyType env (TyVarTy tv)       = tidyTyVarOcc env tv
+ tidyType env (TyConApp tycon tys) = let args = tidyTypes env tys
+                                   in args `seqList` TyConApp tycon args
+ tidyType env (AppTy fun arg)    = (AppTy $! (tidyType env fun)) $! (tidyType env arg)
+ tidyType env (FunTy fun arg)    = (FunTy $! (tidyType env fun)) $! (tidyType env arg)
+ tidyType env (ForAllTy tv ty)   = ForAllTy tvp $! (tidyType envp ty)
+                                 where
+                                   (envp, tvp) = tidyTyVarBndr env tv
+ ---------------
  -- | Grabs the free type variables, tidies them
  -- and then uses 'tidyType' to work over the type itself
  tidyOpenType :: TidyEnv -> Type -> (TidyEnv, Type)
@@@ -612,26 -610,26 +610,30 @@@ uType_np origin orig_ty1 orig_ty
        | isSynFamilyTyCon tc2 = uType_defer origin ty1 ty2   
  
      go (TyConApp tc1 tys1) (TyConApp tc2 tys2)
-       | tc1 == tc2       -- See Note [TyCon app]
-       = do { cos <- uList origin uType tys1 tys2
+       -- See Note [Mismatched type lists and application decomposition]
+       | tc1 == tc2, length tys1 == length tys2
+       = do { cos <- zipWithM (uType origin) tys1 tys2
             ; return $ mkTcTyConAppCo tc1 cos }
 -     
 +
 +    go (LitTy m) ty@(LitTy n)
 +      | m == n
 +      = return $ mkTcReflCo ty
 +
        -- See Note [Care with type applications]
-     go (AppTy s1 t1) ty2
-       | Just (s2,t2) <- tcSplitAppTy_maybe ty2
-       = do { co_s <- uType_np origin s1 s2  -- See Note [Unifying AppTy]
-            ; co_t <- uType origin t1 t2        
-            ; return $ mkTcAppCo co_s co_t }
+         -- Do not decompose FunTy against App; 
+         -- it's often a type error, so leave it for the constraint solver
+     go (AppTy s1 t1) (AppTy s2 t2)
+       = go_app s1 t1 s2 t2
  
-     go ty1 (AppTy s2 t2)
-       | Just (s1,t1) <- tcSplitAppTy_maybe ty1
-       = do { co_s <- uType_np origin s1 s2
-            ; co_t <- uType origin t1 t2
-            ; return $ mkTcAppCo co_s co_t }
+     go (AppTy s1 t1) (TyConApp tc2 ts2)
+       | Just (ts2', t2') <- snocView ts2
+       = ASSERT( isDecomposableTyCon tc2 ) 
+         go_app s1 t1 (TyConApp tc2 ts2') t2'
+     go (TyConApp tc1 ts1) (AppTy s2 t2) 
+       | Just (ts1', t1') <- snocView ts1
+       = ASSERT( isDecomposableTyCon tc1 ) 
+         go_app (TyConApp tc1 ts1') t1' s2 t2 
  
      go ty1 ty2
        | tcIsForAllTy ty1 || tcIsForAllTy ty2