Commit 4179e02e authored by simonpj@microsoft.com's avatar simonpj@microsoft.com
Browse files

Minor refactoring to get rid of Type.splitNewTyConApp

parent 539b5729
......@@ -46,6 +46,7 @@ import {-# SOURCE #-} DsExpr( dsExpr )
import HsSyn
import TcHsSyn
import TcType( tcSplitTyConApp )
import CoreSyn
import DsMonad
......@@ -287,7 +288,8 @@ mkCoAlgCaseMatchResult var ty match_alts
(con1, arg_ids1, match_result1) = ASSERT( notNull match_alts ) head match_alts
arg_id1 = ASSERT( notNull arg_ids1 ) head arg_ids1
var_ty = idType var
(tc, ty_args) = splitNewTyConApp var_ty
(tc, ty_args) = tcSplitTyConApp var_ty -- Don't look through newtypes
-- (not that splitTyConApp does, these days)
newtype_rhs = unwrapNewTypeBody tc ty_args (Var var)
-- Stuff for data types
......
......@@ -384,7 +384,7 @@ ppr_termM1 RefWrap{} = panic "ppr_termM1 - RefWrap"
ppr_termM1 NewtypeWrap{} = panic "ppr_termM1 - NewtypeWrap"
pprNewtypeWrap y p NewtypeWrap{ty=ty, wrapped_term=t}
| Just (tc,_) <- splitNewTyConApp_maybe ty
| Just (tc,_) <- tcSplitTyConApp_maybe ty
, ASSERT(isNewTyCon tc) True
, Just new_dc <- tyConSingleDataCon_maybe tc = do
real_term <- y max_prec t
......@@ -679,7 +679,7 @@ cvObtainTerm hsc_env bound force mb_ty hval = runTR hsc_env $ do
let (t:tt) = unpointed in t : reOrderTerms pointed tt tys
expandNewtypes t@Term{ ty=ty, subTerms=tt }
| Just (tc, args) <- splitNewTyConApp_maybe ty
| Just (tc, args) <- tcSplitTyConApp_maybe ty
, isNewTyCon tc
, wrapped_type <- newTyConInstRhs tc args
, Just dc <- tyConSingleDataCon_maybe tc
......@@ -827,8 +827,8 @@ congruenceNewtypes lhs rhs
(l1',r1') <- congruenceNewtypes l1 r1
return (mkFunTy l1' l2', mkFunTy r1' r2')
-- TyconApp Inductive case; this is the interesting bit.
| Just (tycon_l, _) <- splitNewTyConApp_maybe lhs
, Just (tycon_r, _) <- splitNewTyConApp_maybe rhs
| Just (tycon_l, _) <- tcSplitTyConApp_maybe lhs
, Just (tycon_r, _) <- tcSplitTyConApp_maybe rhs
, tycon_l /= tycon_r
= do rhs' <- upgrade tycon_l rhs
return (lhs, rhs')
......
......@@ -36,7 +36,6 @@ module Type (
mkTyConApp, mkTyConTy,
tyConAppTyCon, tyConAppArgs,
splitTyConApp_maybe, splitTyConApp,
splitNewTyConApp_maybe, splitNewTyConApp,
mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys,
applyTy, applyTys, applyTysD, isForAllTy, dropForAlls,
......@@ -534,20 +533,6 @@ splitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)
splitTyConApp_maybe (FunTy arg res) = Just (funTyCon, [arg,res])
splitTyConApp_maybe _ = Nothing
-- | Sometimes we do NOT want to look through a @newtype@. When case matching
-- on a newtype we want a convenient way to access the arguments of a @newtype@
-- constructor so as to properly form a coercion, and so we use 'splitNewTyConApp'
-- instead of 'splitTyConApp_maybe'
splitNewTyConApp :: Type -> (TyCon, [Type])
splitNewTyConApp ty = case splitNewTyConApp_maybe ty of
Just stuff -> stuff
Nothing -> pprPanic "splitNewTyConApp" (ppr ty)
splitNewTyConApp_maybe :: Type -> Maybe (TyCon, [Type])
splitNewTyConApp_maybe ty | Just ty' <- tcView ty = splitNewTyConApp_maybe ty'
splitNewTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)
splitNewTyConApp_maybe (FunTy arg res) = Just (funTyCon, [arg,res])
splitNewTyConApp_maybe _ = Nothing
newTyConInstRhs :: TyCon -> [Type] -> Type
-- ^ Unwrap one 'layer' of newtype on a type constructor and it's arguments, using an
-- eta-reduced version of the @newtype@ if possible
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment