summaryrefslogtreecommitdiff
path: root/compiler/deSugar
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/deSugar')
-rw-r--r--compiler/deSugar/Check.lhs36
-rw-r--r--compiler/deSugar/Coverage.lhs2
-rw-r--r--compiler/deSugar/Desugar.lhs23
-rw-r--r--compiler/deSugar/DsArrows.lhs3
-rw-r--r--compiler/deSugar/DsBinds.lhs3
-rw-r--r--compiler/deSugar/DsCCall.lhs3
-rw-r--r--compiler/deSugar/DsExpr.lhs4
-rw-r--r--compiler/deSugar/DsForeign.lhs2
-rw-r--r--compiler/deSugar/DsGRHSs.lhs8
-rw-r--r--compiler/deSugar/DsListComp.lhs2
-rw-r--r--compiler/deSugar/DsMeta.hs22
-rw-r--r--compiler/deSugar/DsMonad.lhs2
-rw-r--r--compiler/deSugar/DsUtils.lhs25
-rw-r--r--compiler/deSugar/Match.lhs13
-rw-r--r--compiler/deSugar/MatchCon.lhs36
-rw-r--r--compiler/deSugar/MatchLit.lhs8
16 files changed, 100 insertions, 92 deletions
diff --git a/compiler/deSugar/Check.lhs b/compiler/deSugar/Check.lhs
index c0fe9c03e3..e07a70fc65 100644
--- a/compiler/deSugar/Check.lhs
+++ b/compiler/deSugar/Check.lhs
@@ -5,6 +5,8 @@
% Author: Juan J. Quintela <quintela@krilin.dc.fi.udc.es>
\begin{code}
+{-# LANGUAGE CPP #-}
+
module Check ( check , ExhaustivePat ) where
#include "HsVersions.h"
@@ -21,7 +23,6 @@ import Name
import TysWiredIn
import PrelNames
import TyCon
-import Type
import SrcLoc
import UniqSet
import Util
@@ -123,7 +124,7 @@ untidy_message :: (Name, [HsLit]) -> (Name, [HsLit])
untidy_message (string, lits) = (string, map untidy_lit lits)
\end{code}
-The function @untidy@ does the reverse work of the @tidy_pat@ funcion.
+The function @untidy@ does the reverse work of the @tidy_pat@ function.
\begin{code}
@@ -144,7 +145,7 @@ untidy b (L loc p) = L loc (untidy' b p)
untidy' _ p@(ConPatIn _ (PrefixCon [])) = p
untidy' b (ConPatIn name ps) = pars b (L loc (ConPatIn name (untidy_con ps)))
untidy' _ (ListPat pats ty Nothing) = ListPat (map untidy_no_pars pats) ty Nothing
- untidy' _ (TuplePat pats box ty) = TuplePat (map untidy_no_pars pats) box ty
+ untidy' _ (TuplePat pats box tys) = TuplePat (map untidy_no_pars pats) box tys
untidy' _ (ListPat _ _ (Just _)) = panic "Check.untidy: Overloaded ListPat"
untidy' _ (PArrPat _ _) = panic "Check.untidy: Shouldn't get a parallel array here!"
untidy' _ (SigPatIn _ _) = panic "Check.untidy: SigPat"
@@ -468,8 +469,8 @@ get_unused_cons used_cons = ASSERT( not (null used_cons) ) unused_cons
where
used_set :: UniqSet DataCon
used_set = mkUniqSet [d | ConPatOut{ pat_con = L _ (RealDataCon d) } <- used_cons]
- (ConPatOut { pat_ty = ty }) = head used_cons
- Just (ty_con, inst_tys) = splitTyConApp_maybe ty
+ (ConPatOut { pat_con = L _ (RealDataCon con1), pat_arg_tys = inst_tys }) = head used_cons
+ ty_con = dataConTyCon con1
unused_cons = filterOut is_used (tyConDataCons ty_con)
is_used con = con `elementOfUniqSet` used_set
|| dataConCannotMatch inst_tys con
@@ -593,9 +594,9 @@ make_con (ConPatOut{ pat_con = L _ (RealDataCon id) }) (lp:lq:ps, constraints)
| isInfixCon id = (nlInfixConPat (getName id) lp lq : ps, constraints)
where q = unLoc lq
-make_con (ConPatOut{ pat_con = L _ (RealDataCon id), pat_args = PrefixCon pats, pat_ty = ty }) (ps, constraints)
- | isTupleTyCon tc = (noLoc (TuplePat pats_con (tupleTyConBoxity tc) ty) : rest_pats, constraints)
- | isPArrFakeCon id = (noLoc (PArrPat pats_con placeHolderType) : rest_pats, constraints)
+make_con (ConPatOut{ pat_con = L _ (RealDataCon id), pat_args = PrefixCon pats, pat_arg_tys = tys }) (ps, constraints)
+ | isTupleTyCon tc = (noLoc (TuplePat pats_con (tupleTyConBoxity tc) tys) : rest_pats, constraints)
+ | isPArrFakeCon id = (noLoc (PArrPat pats_con placeHolderType) : rest_pats, constraints)
| otherwise = (nlConPat name pats_con : rest_pats, constraints)
where
name = getName id
@@ -696,17 +697,16 @@ tidy_pat (CoPat _ pat _) = tidy_pat pat
tidy_pat (NPlusKPat id _ _ _) = WildPat (idType (unLoc id))
tidy_pat (ViewPat _ _ ty) = WildPat ty
tidy_pat (ListPat _ _ (Just (ty,_))) = WildPat ty
-tidy_pat (ConPatOut { pat_con = L _ PatSynCon{}, pat_ty = ty })
- = WildPat ty
+tidy_pat (ConPatOut { pat_con = L _ (PatSynCon syn), pat_arg_tys = tys })
+ = WildPat (patSynInstResTy syn tys)
tidy_pat pat@(ConPatOut { pat_con = L _ con, pat_args = ps })
= pat { pat_args = tidy_con con ps }
tidy_pat (ListPat ps ty Nothing)
- = unLoc $ foldr (\ x y -> mkPrefixConPat consDataCon [x,y] list_ty)
- (mkNilPat list_ty)
+ = unLoc $ foldr (\ x y -> mkPrefixConPat consDataCon [x,y] [ty])
+ (mkNilPat ty)
(map tidy_lpat ps)
- where list_ty = mkListTy ty
-- introduce fake parallel array constructors to be able to handle parallel
-- arrays with the existing machinery for constructor pattern
@@ -714,11 +714,11 @@ tidy_pat (ListPat ps ty Nothing)
tidy_pat (PArrPat ps ty)
= unLoc $ mkPrefixConPat (parrFakeCon (length ps))
(map tidy_lpat ps)
- (mkPArrTy ty)
+ [ty]
-tidy_pat (TuplePat ps boxity ty)
+tidy_pat (TuplePat ps boxity tys)
= unLoc $ mkPrefixConPat (tupleCon (boxityNormalTupleSort boxity) arity)
- (map tidy_lpat ps) ty
+ (map tidy_lpat ps) tys
where
arity = length ps
@@ -735,8 +735,8 @@ tidy_lit_pat :: HsLit -> Pat Id
-- overlap with each other, or even explicit lists of Chars.
tidy_lit_pat lit
| HsString s <- lit
- = unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon [mkCharLitPat c, pat] stringTy)
- (mkPrefixConPat nilDataCon [] stringTy) (unpackFS s)
+ = unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon [mkCharLitPat c, pat] [charTy])
+ (mkPrefixConPat nilDataCon [] [charTy]) (unpackFS s)
| otherwise
= tidyLitPat lit
diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs
index 6bdc61d9c2..e646667651 100644
--- a/compiler/deSugar/Coverage.lhs
+++ b/compiler/deSugar/Coverage.lhs
@@ -3,6 +3,8 @@
% (c) University of Glasgow, 2007
%
\begin{code}
+{-# LANGUAGE NondecreasingIndentation #-}
+
module Coverage (addTicksToBinds, hpcInitCode) where
import Type
diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs
index cd75de9a3a..3160b35f15 100644
--- a/compiler/deSugar/Desugar.lhs
+++ b/compiler/deSugar/Desugar.lhs
@@ -6,6 +6,8 @@
The Desugarer: turning HsSyn into Core.
\begin{code}
+{-# LANGUAGE CPP #-}
+
module Desugar ( deSugar, deSugarExpr ) where
import DynFlags
@@ -50,8 +52,6 @@ import OrdList
import Data.List
import Data.IORef
import Control.Monad( when )
-import Data.Maybe ( mapMaybe )
-import UniqFM
\end{code}
%************************************************************************
@@ -123,27 +123,20 @@ deSugar hsc_env
; let hpc_init
| gopt Opt_Hpc dflags = hpcInitCode mod ds_hpc_info
| otherwise = empty
- ; let patsyn_defs = [(patSynId ps, ps) | ps <- patsyns]
; return ( ds_ev_binds
, foreign_prs `appOL` core_prs `appOL` spec_prs
, spec_rules ++ ds_rules, ds_vects
- , ds_fords `appendStubC` hpc_init
- , patsyn_defs) }
+ , ds_fords `appendStubC` hpc_init) }
; case mb_res of {
Nothing -> return (msgs, Nothing) ;
- Just (ds_ev_binds, all_prs, all_rules, vects0, ds_fords, patsyn_defs) -> do
+ Just (ds_ev_binds, all_prs, all_rules, vects0, ds_fords) -> do
do { -- Add export flags to bindings
keep_alive <- readIORef keep_var
- ; let (rules_for_locals, rules_for_imps)
- = partition isLocalRule all_rules
- final_patsyns = addExportFlagsAndRules target export_set keep_alive [] patsyn_defs
- exp_patsyn_wrappers = mapMaybe (patSynWrapper . snd) final_patsyns
- exp_patsyn_matchers = map (patSynMatcher . snd) final_patsyns
- keep_alive' = addListToUFM keep_alive (map (\x -> (x, getName x)) (exp_patsyn_wrappers ++ exp_patsyn_matchers))
- final_prs = addExportFlagsAndRules target
- export_set keep_alive' rules_for_locals (fromOL all_prs)
+ ; let (rules_for_locals, rules_for_imps) = partition isLocalRule all_rules
+ final_prs = addExportFlagsAndRules target export_set keep_alive
+ rules_for_locals (fromOL all_prs)
final_pgm = combineEvBinds ds_ev_binds final_prs
-- Notice that we put the whole lot in a big Rec, even the foreign binds
@@ -187,7 +180,7 @@ deSugar hsc_env
mg_fam_insts = fam_insts,
mg_inst_env = inst_env,
mg_fam_inst_env = fam_inst_env,
- mg_patsyns = map snd . filter (isExportedId . fst) $ final_patsyns,
+ mg_patsyns = filter ((`elemNameSet` export_set) . patSynName) patsyns,
mg_rules = ds_rules_for_imps,
mg_binds = ds_binds,
mg_foreign = ds_fords,
diff --git a/compiler/deSugar/DsArrows.lhs b/compiler/deSugar/DsArrows.lhs
index f87877681c..1bbcc05e40 100644
--- a/compiler/deSugar/DsArrows.lhs
+++ b/compiler/deSugar/DsArrows.lhs
@@ -6,7 +6,8 @@
Desugaring arrow commands
\begin{code}
-{-# OPTIONS -fno-warn-tabs #-}
+{-# LANGUAGE CPP #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and
-- detab the module (please do the detabbing in a separate patch). See
diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs
index 1dbf530123..9691b99975 100644
--- a/compiler/deSugar/DsBinds.lhs
+++ b/compiler/deSugar/DsBinds.lhs
@@ -10,7 +10,8 @@ in that the @Rec@/@NonRec@/etc structure is thrown away (whereas at
lower levels it is preserved with @let@/@letrec@s).
\begin{code}
-{-# OPTIONS -fno-warn-tabs #-}
+{-# LANGUAGE CPP #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and
-- detab the module (please do the detabbing in a separate patch). See
diff --git a/compiler/deSugar/DsCCall.lhs b/compiler/deSugar/DsCCall.lhs
index 80f2ec525f..217a4ce7c9 100644
--- a/compiler/deSugar/DsCCall.lhs
+++ b/compiler/deSugar/DsCCall.lhs
@@ -6,7 +6,8 @@
Desugaring foreign calls
\begin{code}
-{-# OPTIONS -fno-warn-tabs #-}
+{-# LANGUAGE CPP #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and
-- detab the module (please do the detabbing in a separate patch). See
diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs
index 859309d592..4eadef69b8 100644
--- a/compiler/deSugar/DsExpr.lhs
+++ b/compiler/deSugar/DsExpr.lhs
@@ -6,6 +6,8 @@
Desugaring exporessions.
\begin{code}
+{-# LANGUAGE CPP #-}
+
module DsExpr ( dsExpr, dsLExpr, dsLocalBinds, dsValBinds, dsLit ) where
#include "HsVersions.h"
@@ -548,7 +550,7 @@ dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields })
, pat_dicts = eqs_vars ++ theta_vars
, pat_binds = emptyTcEvBinds
, pat_args = PrefixCon $ map nlVarPat arg_ids
- , pat_ty = in_ty
+ , pat_arg_tys = in_inst_tys
, pat_wrap = idHsWrapper }
; let wrapped_rhs | null eq_spec = rhs
| otherwise = mkLHsWrap (mkWpCast (mkTcSubCo wrap_co)) rhs
diff --git a/compiler/deSugar/DsForeign.lhs b/compiler/deSugar/DsForeign.lhs
index e2f4f4ff3c..0654ebc983 100644
--- a/compiler/deSugar/DsForeign.lhs
+++ b/compiler/deSugar/DsForeign.lhs
@@ -6,6 +6,8 @@
Desugaring foreign declarations (see also DsCCall).
\begin{code}
+{-# LANGUAGE CPP #-}
+
module DsForeign ( dsForeigns
, dsForeigns'
, dsFImport, dsCImport, dsFCall, dsPrimCall
diff --git a/compiler/deSugar/DsGRHSs.lhs b/compiler/deSugar/DsGRHSs.lhs
index 4573e54ce0..a571e807d4 100644
--- a/compiler/deSugar/DsGRHSs.lhs
+++ b/compiler/deSugar/DsGRHSs.lhs
@@ -6,6 +6,8 @@
Matching guarded right-hand-sides (GRHSs)
\begin{code}
+{-# LANGUAGE CPP #-}
+
module DsGRHSs ( dsGuarded, dsGRHSs, dsGRHS ) where
#include "HsVersions.h"
@@ -61,10 +63,8 @@ dsGRHSs hs_ctx _ (GRHSs grhss binds) rhs_ty
= ASSERT( notNull grhss )
do { match_results <- mapM (dsGRHS hs_ctx rhs_ty) grhss
; let match_result1 = foldr1 combineMatchResults match_results
- match_result2 = adjustMatchResultDs
- (\e -> dsLocalBinds binds e)
- match_result1
- -- NB: nested dsLet inside matchResult
+ match_result2 = adjustMatchResultDs (dsLocalBinds binds) match_result1
+ -- NB: nested dsLet inside matchResult
; return match_result2 }
dsGRHS :: HsMatchContext Name -> Type -> LGRHS Id (LHsExpr Id) -> DsM MatchResult
diff --git a/compiler/deSugar/DsListComp.lhs b/compiler/deSugar/DsListComp.lhs
index a1131a8126..2111c95f82 100644
--- a/compiler/deSugar/DsListComp.lhs
+++ b/compiler/deSugar/DsListComp.lhs
@@ -6,7 +6,7 @@
Desugaring list comprehensions, monad comprehensions and array comprehensions
\begin{code}
-{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE CPP, NamedFieldPuns #-}
module DsListComp ( dsListComp, dsPArrComp, dsMonadComp ) where
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index 73c1adfdc8..adfc0f688f 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE CPP #-}
+
-----------------------------------------------------------------------------
--
-- (c) The University of Glasgow 2006
@@ -394,10 +396,10 @@ repTyFamInstD decl@(TyFamInstDecl { tfid_eqn = eqn })
; repTySynInst tc eqn1 }
repTyFamEqn :: LTyFamInstEqn Name -> DsM (Core TH.TySynEqnQ)
-repTyFamEqn (L loc (TyFamInstEqn { tfie_pats = HsWB { hswb_cts = tys
- , hswb_kvs = kv_names
- , hswb_tvs = tv_names }
- , tfie_rhs = rhs }))
+repTyFamEqn (L loc (TyFamEqn { tfe_pats = HsWB { hswb_cts = tys
+ , hswb_kvs = kv_names
+ , hswb_tvs = tv_names }
+ , tfe_rhs = rhs }))
= do { let hs_tvs = HsQTvs { hsq_kvs = kv_names
, hsq_tvs = userHsTyVarBndrs loc tv_names } -- Yuk
; addTyClTyVarBinds hs_tvs $ \ _ ->
@@ -705,12 +707,14 @@ addTyVarBinds :: LHsTyVarBndrs Name -- the binders to
-- the computations passed as the second argument is executed in that extended
-- meta environment and gets the *new* names on Core-level as an argument
-addTyVarBinds tvs m
- = do { freshNames <- mkGenSyms (hsLKiTyVarNames tvs)
- ; term <- addBinds freshNames $
- do { kbs <- repList tyVarBndrTyConName mk_tv_bndr (hsQTvBndrs tvs `zip` freshNames)
+addTyVarBinds (HsQTvs { hsq_kvs = kvs, hsq_tvs = tvs }) m
+ = do { fresh_kv_names <- mkGenSyms kvs
+ ; fresh_tv_names <- mkGenSyms (map hsLTyVarName tvs)
+ ; let fresh_names = fresh_kv_names ++ fresh_tv_names
+ ; term <- addBinds fresh_names $
+ do { kbs <- repList tyVarBndrTyConName mk_tv_bndr (tvs `zip` fresh_tv_names)
; m kbs }
- ; wrapGenSyms freshNames term }
+ ; wrapGenSyms fresh_names term }
where
mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v)
diff --git a/compiler/deSugar/DsMonad.lhs b/compiler/deSugar/DsMonad.lhs
index b590f4b2d2..c017a7cc01 100644
--- a/compiler/deSugar/DsMonad.lhs
+++ b/compiler/deSugar/DsMonad.lhs
@@ -6,6 +6,8 @@
@DsMonad@: monadery used in desugaring
\begin{code}
+{-# LANGUAGE FlexibleInstances #-}
+
module DsMonad (
DsM, mapM, mapAndUnzipM,
initDs, initDsTc, fixDs,
diff --git a/compiler/deSugar/DsUtils.lhs b/compiler/deSugar/DsUtils.lhs
index 2ad70c67d3..c52b917efd 100644
--- a/compiler/deSugar/DsUtils.lhs
+++ b/compiler/deSugar/DsUtils.lhs
@@ -8,7 +8,8 @@ Utilities for desugaring
This module exports some utility functions of no great interest.
\begin{code}
-{-# OPTIONS -fno-warn-tabs #-}
+{-# LANGUAGE CPP #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and
-- detab the module (please do the detabbing in a separate patch). See
@@ -64,7 +65,6 @@ import ConLike
import DataCon
import PatSyn
import Type
-import Coercion
import TysPrim
import TysWiredIn
import BasicTypes
@@ -638,12 +638,13 @@ mkSelectorBinds ticks pat val_expr
-- efficient too.
-- For the error message we make one error-app, to avoid duplication.
- -- But we need it at different types... so we use coerce for that
- ; err_expr <- mkErrorAppDs iRREFUT_PAT_ERROR_ID unitTy (ppr pat)
- ; err_var <- newSysLocalDs unitTy
- ; binds <- zipWithM (mk_bind val_var err_var) ticks' binders
- ; return ( (val_var, val_expr) :
- (err_var, err_expr) :
+ -- But we need it at different types, so we make it polymorphic:
+ -- err_var = /\a. iRREFUT_PAT_ERR a "blah blah blah"
+ ; err_app <- mkErrorAppDs iRREFUT_PAT_ERROR_ID alphaTy (ppr pat)
+ ; err_var <- newSysLocalDs (mkForAllTy alphaTyVar alphaTy)
+ ; binds <- zipWithM (mk_bind val_var err_var) ticks' binders
+ ; return ( (val_var, val_expr) :
+ (err_var, Lam alphaTyVar err_app) :
binds ) }
| otherwise
@@ -665,14 +666,13 @@ mkSelectorBinds ticks pat val_expr
mk_bind scrut_var err_var tick bndr_var = do
-- (mk_bind sv err_var) generates
- -- bv = case sv of { pat -> bv; other -> coerce (type-of-bv) err_var }
+ -- bv = case sv of { pat -> bv; other -> err_var @ type-of-bv }
-- Remember, pat binds bv
rhs_expr <- matchSimply (Var scrut_var) PatBindRhs pat
(Var bndr_var) error_expr
return (bndr_var, mkOptTickBox tick rhs_expr)
where
- error_expr = mkCast (Var err_var) co
- co = mkUnsafeCo (exprType (Var err_var)) (idType bndr_var)
+ error_expr = Var err_var `App` Type (idType bndr_var)
is_simple_lpat p = is_simple_pat (unLoc p)
@@ -709,8 +709,7 @@ mkLHsVarPatTup bs = mkLHsPatTup (map nlVarPat bs)
mkVanillaTuplePat :: [OutPat Id] -> Boxity -> Pat Id
-- A vanilla tuple pattern simply gets its type from its sub-patterns
-mkVanillaTuplePat pats box
- = TuplePat pats box (mkTupleTy (boxityNormalTupleSort box) (map hsLPatType pats))
+mkVanillaTuplePat pats box = TuplePat pats box (map hsLPatType pats)
-- The Big equivalents for the source tuple expressions
mkBigLHsVarTup :: [Id] -> LHsExpr Id
diff --git a/compiler/deSugar/Match.lhs b/compiler/deSugar/Match.lhs
index b42a720c32..a14027862a 100644
--- a/compiler/deSugar/Match.lhs
+++ b/compiler/deSugar/Match.lhs
@@ -6,6 +6,8 @@
The @match@ function
\begin{code}
+{-# LANGUAGE CPP #-}
+
module Match ( match, matchEquations, matchWrapper, matchSimply, matchSinglePat ) where
#include "HsVersions.h"
@@ -552,9 +554,8 @@ tidy1 v (LazyPat pat)
tidy1 _ (ListPat pats ty Nothing)
= return (idDsWrapper, unLoc list_ConPat)
where
- list_ty = mkListTy ty
- list_ConPat = foldr (\ x y -> mkPrefixConPat consDataCon [x, y] list_ty)
- (mkNilPat list_ty)
+ list_ConPat = foldr (\ x y -> mkPrefixConPat consDataCon [x, y] [ty])
+ (mkNilPat ty)
pats
-- Introduce fake parallel array constructors to be able to handle parallel
@@ -563,13 +564,13 @@ tidy1 _ (PArrPat pats ty)
= return (idDsWrapper, unLoc parrConPat)
where
arity = length pats
- parrConPat = mkPrefixConPat (parrFakeCon arity) pats (mkPArrTy ty)
+ parrConPat = mkPrefixConPat (parrFakeCon arity) pats [ty]
-tidy1 _ (TuplePat pats boxity ty)
+tidy1 _ (TuplePat pats boxity tys)
= return (idDsWrapper, unLoc tuple_ConPat)
where
arity = length pats
- tuple_ConPat = mkPrefixConPat (tupleCon (boxityNormalTupleSort boxity) arity) pats ty
+ tuple_ConPat = mkPrefixConPat (tupleCon (boxityNormalTupleSort boxity) arity) pats tys
-- LitPats: we *might* be able to replace these w/ a simpler form
tidy1 _ (LitPat lit)
diff --git a/compiler/deSugar/MatchCon.lhs b/compiler/deSugar/MatchCon.lhs
index 2b51638bf3..8e581f66e2 100644
--- a/compiler/deSugar/MatchCon.lhs
+++ b/compiler/deSugar/MatchCon.lhs
@@ -6,7 +6,8 @@
Pattern-matching constructors
\begin{code}
-{-# OPTIONS -fno-warn-tabs #-}
+{-# LANGUAGE CPP #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and
-- detab the module (please do the detabbing in a separate patch). See
@@ -124,7 +125,7 @@ matchOneConLike :: [Id]
-> [EquationInfo]
-> DsM (CaseAlt ConLike)
matchOneConLike vars ty (eqn1 : eqns) -- All eqns for a single constructor
- = do { arg_vars <- selectConMatchVars arg_tys args1
+ = do { arg_vars <- selectConMatchVars val_arg_tys args1
-- Use the first equation as a source of
-- suggestions for the new variables
@@ -140,27 +141,24 @@ matchOneConLike vars ty (eqn1 : eqns) -- All eqns for a single constructor
alt_wrapper = wrapper1,
alt_result = foldr1 combineMatchResults match_results } }
where
- ConPatOut { pat_con = L _ con1, pat_ty = pat_ty1, pat_wrap = wrapper1,
+ ConPatOut { pat_con = L _ con1, pat_arg_tys = arg_tys, pat_wrap = wrapper1,
pat_tvs = tvs1, pat_dicts = dicts1, pat_args = args1 }
= firstPat eqn1
fields1 = case con1 of
- RealDataCon dcon1 -> dataConFieldLabels dcon1
- PatSynCon{} -> []
-
- arg_tys = inst inst_tys
- where
- inst = case con1 of
- RealDataCon dcon1 -> dataConInstOrigArgTys dcon1
- PatSynCon psyn1 -> patSynInstArgTys psyn1
- inst_tys = tcTyConAppArgs pat_ty1 ++
- mkTyVarTys (takeList exVars tvs1)
- -- Newtypes opaque, hence tcTyConAppArgs
+ RealDataCon dcon1 -> dataConFieldLabels dcon1
+ PatSynCon{} -> []
+
+ val_arg_tys = case con1 of
+ RealDataCon dcon1 -> dataConInstOrigArgTys dcon1 inst_tys
+ PatSynCon psyn1 -> patSynInstArgTys psyn1 inst_tys
+ inst_tys = ASSERT( tvs1 `equalLength` ex_tvs )
+ arg_tys ++ mkTyVarTys tvs1
-- dataConInstOrigArgTys takes the univ and existential tyvars
-- and returns the types of the *value* args, which is what we want
- where
- exVars = case con1 of
- RealDataCon dcon1 -> dataConExTyVars dcon1
- PatSynCon psyn1 -> patSynExTyVars psyn1
+
+ ex_tvs = case con1 of
+ RealDataCon dcon1 -> dataConExTyVars dcon1
+ PatSynCon psyn1 -> patSynExTyVars psyn1
match_group :: [Id] -> [(ConArgPats, EquationInfo)] -> DsM MatchResult
-- All members of the group have compatible ConArgPats
@@ -178,7 +176,7 @@ matchOneConLike vars ty (eqn1 : eqns) -- All eqns for a single constructor
return ( wrapBinds (tvs `zip` tvs1)
. wrapBinds (ds `zip` dicts1)
. mkCoreLets ds_bind
- , eqn { eqn_pats = conArgPats arg_tys args ++ pats }
+ , eqn { eqn_pats = conArgPats val_arg_tys args ++ pats }
)
shift (_, (EqnInfo { eqn_pats = ps })) = pprPanic "matchOneCon/shift" (ppr ps)
diff --git a/compiler/deSugar/MatchLit.lhs b/compiler/deSugar/MatchLit.lhs
index 7429a613d9..350ed22d69 100644
--- a/compiler/deSugar/MatchLit.lhs
+++ b/compiler/deSugar/MatchLit.lhs
@@ -6,6 +6,8 @@
Pattern-matching literal patterns
\begin{code}
+{-# LANGUAGE CPP, ScopedTypeVariables #-}
+
module MatchLit ( dsLit, dsOverLit, hsLitKey, hsOverLitKey
, tidyLitPat, tidyNPat
, matchLiterals, matchNPlusKPats, matchNPats
@@ -264,8 +266,8 @@ tidyLitPat :: HsLit -> Pat Id
tidyLitPat (HsChar c) = unLoc (mkCharLitPat c)
tidyLitPat (HsString s)
| lengthFS s <= 1 -- Short string literals only
- = unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon [mkCharLitPat c, pat] stringTy)
- (mkNilPat stringTy) (unpackFS s)
+ = unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon [mkCharLitPat c, pat] [charTy])
+ (mkNilPat charTy) (unpackFS s)
-- The stringTy is the type of the whole pattern, not
-- the type to instantiate (:) or [] with!
tidyLitPat lit = LitPat lit
@@ -297,7 +299,7 @@ tidyNPat tidy_lit_pat (OverLit val False _ ty) mb_neg _
| isStringTy ty, Just str_lit <- mb_str_lit = tidy_lit_pat (HsString str_lit)
where
mk_con_pat :: DataCon -> HsLit -> Pat Id
- mk_con_pat con lit = unLoc (mkPrefixConPat con [noLoc $ LitPat lit] ty)
+ mk_con_pat con lit = unLoc (mkPrefixConPat con [noLoc $ LitPat lit] [])
mb_int_lit :: Maybe Integer
mb_int_lit = case (mb_neg, val) of
View Lorry Controller Status