TcPatSyn.hs 35.7 KB
Newer Older
Austin Seipp's avatar
Austin Seipp committed
1 2 3 4
{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998

Gergő Érdi's avatar
Gergő Érdi committed
5
\section[TcPatSyn]{Typechecking pattern synonym declarations}
Austin Seipp's avatar
Austin Seipp committed
6
-}
Gergő Érdi's avatar
Gergő Érdi committed
7

8
{-# LANGUAGE CPP #-}
9
{-# LANGUAGE FlexibleContexts #-}
10

11
module TcPatSyn ( tcInferPatSynDecl, tcCheckPatSynDecl
Matthew Pickering's avatar
Matthew Pickering committed
12
                , tcPatSynBuilderBind, tcPatSynBuilderOcc, nonBidirectionalErr
13
  ) where
Gergő Érdi's avatar
Gergő Érdi committed
14 15 16

import HsSyn
import TcPat
17
import Type( binderVar, mkNamedBinders, binderVisibility, mkEmptyTCvSubst
18
           , tidyTyCoVarBndrs, tidyTypes, tidyType )
Gergő Érdi's avatar
Gergő Érdi committed
19
import TcRnMonad
20
import TcSigs( emptyPragEnv, completeSigFromId )
Gergő Érdi's avatar
Gergő Érdi committed
21 22 23
import TcEnv
import TcMType
import TysPrim
24
import TysWiredIn  ( runtimeRepTy )
Gergő Érdi's avatar
Gergő Érdi committed
25 26 27 28 29 30 31 32
import Name
import SrcLoc
import PatSyn
import NameSet
import Panic
import Outputable
import FastString
import Var
33
import VarEnv( emptyTidyEnv, mkInScopeSet )
Gergő Érdi's avatar
Gergő Érdi committed
34
import Id
35
import IdInfo( RecSelParent(..))
Gergő Érdi's avatar
Gergő Érdi committed
36 37 38
import TcBinds
import BasicTypes
import TcSimplify
39
import TcUnify
Gergő Érdi's avatar
Gergő Érdi committed
40
import TcType
41 42
import TcEvidence
import BuildTyCl
Gergő Érdi's avatar
Gergő Érdi committed
43
import VarSet
44
import MkId
45
import TcTyDecls
Matthew Pickering's avatar
Matthew Pickering committed
46 47
import ConLike
import FieldLabel
Gergő Érdi's avatar
Gergő Érdi committed
48
import Bag
49
import Util
50
import ErrUtils
51
import FV
52
import Control.Monad ( zipWithM )
53
import Data.List( partition )
Gergő Érdi's avatar
Gergő Érdi committed
54 55 56

#include "HsVersions.h"

Austin Seipp's avatar
Austin Seipp committed
57 58 59
{-
************************************************************************
*                                                                      *
60
                    Type checking a pattern synonym
Austin Seipp's avatar
Austin Seipp committed
61 62 63
*                                                                      *
************************************************************************
-}
64

65
tcInferPatSynDecl :: PatSynBind Name Name
66
                  -> TcM (LHsBinds Id, TcGblEnv)
67
tcInferPatSynDecl PSB{ psb_id = lname@(L _ name), psb_args = details,
68
                       psb_def = lpat, psb_dir = dir }
69
  = addPatSynCtxt lname $
70
    do { traceTc "tcInferPatSynDecl {" $ ppr name
71
       ; tcCheckPatSynPat lpat
Gergő Érdi's avatar
Gergő Érdi committed
72

Matthew Pickering's avatar
Matthew Pickering committed
73
       ; let (arg_names, rec_fields, is_infix) = collectPatSynArgInfo details
74
       ; (tclvl, wanted, ((lpat', args), pat_ty))
75
            <- pushLevelAndCaptureConstraints  $
76 77 78 79 80
               do { pat_ty <- newOpenInferExpType
                  ; stuff <- tcPat PatSyn lpat pat_ty $
                             mapM tcLookupId arg_names
                  ; pat_ty <- readExpType pat_ty
                  ; return (stuff, pat_ty) }
81 82

       ; let named_taus = (name, pat_ty) : map (\arg -> (getName arg, varType arg)) args
Gergő Érdi's avatar
Gergő Érdi committed
83

84
       ; (qtvs, req_dicts, ev_binds) <- simplifyInfer tclvl False [] named_taus wanted
Gergő Érdi's avatar
Gergő Érdi committed
85

86
       ; let ((ex_tvs, ex_vars), prov_dicts) = tcCollectEx lpat'
87
             univ_tvs   = filter (not . (`elemVarSet` ex_vars)) qtvs
88 89
             prov_theta = map evVarPred prov_dicts
             req_theta  = map evVarPred req_dicts
Gergő Érdi's avatar
Gergő Érdi committed
90

91
       ; traceTc "tcInferPatSynDecl }" $ ppr name
92 93 94 95 96
       ; tc_patsyn_finish lname dir is_infix lpat'
                          (univ_tvs, mkNamedBinders Invisible univ_tvs
                            , req_theta,  ev_binds, req_dicts)
                          (ex_tvs,   mkNamedBinders Invisible ex_tvs
                            , mkTyVarTys ex_tvs, prov_theta, map EvId prov_dicts)
97
                          (map nlHsVar args, map idType args)
Matthew Pickering's avatar
Matthew Pickering committed
98 99
                          pat_ty rec_fields }

100 101 102

tcCheckPatSynDecl :: PatSynBind Name Name
                  -> TcPatSynInfo
103
                  -> TcM (LHsBinds Id, TcGblEnv)
104 105
tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details
                         , psb_def = lpat, psb_dir = dir }
106 107 108 109
                  TPSI{ patsig_implicit_bndrs = implicit_tvs
                      , patsig_univ_bndrs = explicit_univ_tvs, patsig_prov = prov_theta
                      , patsig_ex_bndrs   = explicit_ex_tvs,   patsig_req  = req_theta
                      , patsig_body_ty    = sig_body_ty }
110
  = addPatSynCtxt lname $
111
    do { let decl_arity = length arg_names
112 113 114
             (arg_names, rec_fields, is_infix) = collectPatSynArgInfo details

       ; traceTc "tcCheckPatSynDecl" $
115 116
         vcat [ ppr implicit_tvs, ppr explicit_univ_tvs, ppr req_theta
              , ppr explicit_ex_tvs, ppr prov_theta, ppr sig_body_ty ]
117

118 119
       ; tcCheckPatSynPat lpat

120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143
       ; (arg_tys, pat_ty) <- case tcSplitFunTysN decl_arity sig_body_ty of
                                 Right stuff  -> return stuff
                                 Left missing -> wrongNumberOfParmsErr name decl_arity missing

       -- Complain about:  pattern P :: () => forall x. x -> P x
       -- The existential 'x' should not appear in the result type
       -- Can't check this until we know P's arity
       ; let bad_tvs = filter (`elemVarSet` tyCoVarsOfType pat_ty) explicit_ex_tvs
       ; checkTc (null bad_tvs) $
         hang (sep [ text "The result type of the signature for" <+> quotes (ppr name) <> comma
                   , text "namely" <+> quotes (ppr pat_ty) ])
            2 (text "mentions existential type variable" <> plural bad_tvs
               <+> pprQuotedList bad_tvs)

         -- See Note [The pattern-synonym signature splitting rule]
       ; let get_tv = binderVar "tcCheckPatSynDecl"
             univ_fvs = closeOverKinds $
                        (tyCoVarsOfTypes (pat_ty : req_theta) `extendVarSetList` explicit_univ_tvs)
             (extra_univ, extra_ex) = partition ((`elemVarSet` univ_fvs) . get_tv) implicit_tvs
             univ_bndrs = extra_univ ++ mkNamedBinders Specified explicit_univ_tvs
             ex_bndrs   = extra_ex   ++ mkNamedBinders Specified explicit_ex_tvs
             univ_tvs   = map get_tv univ_bndrs
             ex_tvs     = map get_tv ex_bndrs

144 145
       -- Right!  Let's check the pattern against the signature
       -- See Note [Checking against a pattern signature]
146
       ; req_dicts <- newEvVars req_theta
147 148
       ; (tclvl, wanted, (lpat', (ex_tvs', prov_dicts, args'))) <-
           ASSERT2( equalLength arg_names arg_tys, ppr name $$ ppr arg_names $$ ppr arg_tys )
149 150 151
           pushLevelAndCaptureConstraints            $
           tcExtendTyVarEnv univ_tvs                 $
           tcPat PatSyn lpat (mkCheckExpType pat_ty) $
152 153 154 155 156
           do { let new_tv | isUnidirectional dir = newMetaTyVarX
                           | otherwise            = newMetaSigTyVarX
                    in_scope    = mkInScopeSet (mkVarSet univ_tvs)
                    empty_subst = mkEmptyTCvSubst in_scope
              ; (subst, ex_tvs') <- mapAccumLM new_tv empty_subst ex_tvs
Rik Steenkamp's avatar
Rik Steenkamp committed
157
                    -- See the "Existential type variables" part of
158
                    -- Note [Checking against a pattern signature]
159 160
              ; traceTc "tcpatsyn1" (vcat [ ppr v <+> dcolon <+> ppr (tyVarKind v) | v <- ex_tvs])
              ; traceTc "tcpatsyn2" (vcat [ ppr v <+> dcolon <+> ppr (tyVarKind v) | v <- ex_tvs'])
161
              ; let prov_theta' = substTheta subst prov_theta
162
                  -- Add univ_tvs to the in_scope set to
163 164 165 166
                  -- satisfy the substition invariant. There's no need to
                  -- add 'ex_tvs' as they are already in the domain of the
                  -- substitution.
                  -- See also Note [The substitution invariant] in TyCoRep.
167
              ; prov_dicts <- mapM (emitWanted (ProvCtxtOrigin psb)) prov_theta'
168 169 170
              ; args'      <- zipWithM (tc_arg subst) arg_names arg_tys
              ; return (ex_tvs', prov_dicts, args') }

171 172 173 174
       ; let skol_info = SigSkol (PatSynCtxt name) (mkPhiTy req_theta pat_ty)
                         -- The type here is a bit bogus, but we do not print
                         -- the type for PatSynCtxt, so it doesn't matter
                         -- See TcRnTypes Note [Skolem info for pattern synonyms]
175
       ; (implics, ev_binds) <- buildImplicationFor tclvl skol_info univ_tvs req_dicts wanted
176

177 178 179
       -- Solve the constraints now, because we are about to make a PatSyn,
       -- which should not contain unification variables and the like (Trac #10997)
       -- Since all the inputs are implications the returned bindings will be empty
180
       ; _ <- simplifyTop (mkImplicWC implics)
181 182 183 184

       -- ToDo: in the bidirectional case, check that the ex_tvs' are all distinct
       -- Otherwise we may get a type error when typechecking the builder,
       -- when that should be impossible
185

186
       ; traceTc "tcCheckPatSynDecl }" $ ppr name
187 188 189
       ; tc_patsyn_finish lname dir is_infix lpat'
                          (univ_tvs, univ_bndrs, req_theta, ev_binds, req_dicts)
                          (ex_tvs, ex_bndrs, mkTyVarTys ex_tvs', prov_theta, prov_dicts)
190
                          (args', arg_tys)
191
                          pat_ty rec_fields }
192
  where
193 194 195 196 197 198 199
    tc_arg :: TCvSubst -> Name -> Type -> TcM (LHsExpr TcId)
    tc_arg subst arg_name arg_ty
      = do {   -- Look up the variable actually bound by lpat
               -- and check that it has the expected type
             arg_id <- tcLookupId arg_name
           ; coi <- unifyType (Just arg_id)
                              (idType arg_id)
200
                              (substTyUnchecked subst arg_ty)
201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217
           ; return (mkLHsWrapCo coi $ nlHsVar arg_id) }

{- Note [Checking against a pattern signature]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When checking the actual supplied pattern against the pattern synonym
signature, we need to be quite careful.

----- Provided constraints
Example

    data T a where
      MkT :: Ord a => a -> T a

    pattern P :: () => Eq a => a -> [T a]
    pattern P x = [MkT x]

We must check that the (Eq a) that P claims to bind (and to
Rik Steenkamp's avatar
Rik Steenkamp committed
218 219
make available to matches against P), is derivable from the
actual pattern.  For example:
220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250
    f (P (x::a)) = ...here (Eq a) should be available...
And yes, (Eq a) is derivable from the (Ord a) bound by P's rhs.

----- Existential type variables
Unusually, we instantiate the existential tyvars of the pattern with
*meta* type variables.  For example

    data S where
      MkS :: Eq a => [a] -> S

    pattern P :: () => Eq x => x -> S
    pattern P x <- MkS x

The pattern synonym conceals from its client the fact that MkS has a
list inside it.  The client just thinks it's a type 'x'.  So we must
unify x := [a] during type checking, and then use the instantiating type
[a] (called ex_tys) when building the matcher.  In this case we'll get

   $mP :: S -> (forall x. Ex x => x -> r) -> r -> r
   $mP x k = case x of
               MkS a (d:Eq a) (ys:[a]) -> let dl :: Eq [a]
                                              dl = $dfunEqList d
                                          in k [a] dl ys

This "concealing" story works for /uni-directional/ pattern synonmys,
but obviously not for bidirectional ones.  So in the bidirectional case
we use SigTv, rather than a generic TauTv, meta-tyvar so that.  And
we should really check that those SigTvs don't get unified with each
other.

-}
251

Matthew Pickering's avatar
Matthew Pickering committed
252 253 254 255 256 257 258 259 260 261 262 263 264 265 266
collectPatSynArgInfo :: HsPatSynDetails (Located Name) -> ([Name], [Name], Bool)
collectPatSynArgInfo details =
  case details of
    PrefixPatSyn names      -> (map unLoc names, [], False)
    InfixPatSyn name1 name2 -> (map unLoc [name1, name2], [], True)
    RecordPatSyn names ->
      let (vars, sels) = unzip (map splitRecordPatSyn names)
      in (vars, sels, False)

  where
    splitRecordPatSyn :: RecordPatSynField (Located Name) -> (Name, Name)
    splitRecordPatSyn (RecordPatSynField { recordPatSynPatVar = L _ patVar
                                         , recordPatSynSelectorId = L _ selId })
      = (patVar, selId)

267 268 269
addPatSynCtxt :: Located Name -> TcM a -> TcM a
addPatSynCtxt (L loc name) thing_inside
  = setSrcSpan loc $
270
    addErrCtxt (text "In the declaration for pattern synonym"
271 272 273
                <+> quotes (ppr name)) $
    thing_inside

274 275 276 277
wrongNumberOfParmsErr :: Name -> Arity -> Arity -> TcM a
wrongNumberOfParmsErr name decl_arity missing
  = failWithTc $
    hang (text "Pattern synonym" <+> quotes (ppr name) <+> ptext (sLit "has")
278
          <+> speakNOf decl_arity (text "argument"))
279
       2 (text "but its type signature has" <+> int missing <+> text "fewer arrows")
280

281 282
-------------------------
-- Shared by both tcInferPatSyn and tcCheckPatSyn
Matthew Pickering's avatar
Matthew Pickering committed
283 284 285 286
tc_patsyn_finish :: Located Name  -- ^ PatSyn Name
                 -> HsPatSynDir Name  -- ^ PatSyn type (Uni/Bidir/ExplicitBidir)
                 -> Bool              -- ^ Whether infix
                 -> LPat Id           -- ^ Pattern of the PatSyn
287 288
                 -> ([TcTyVar], [TcTyBinder], [PredType], TcEvBinds, [EvVar])
                 -> ([TcTyVar], [TcTyBinder], [TcType], [PredType], [EvTerm])
289
                 -> ([LHsExpr TcId], [TcType])   -- ^ Pattern arguments and types
Matthew Pickering's avatar
Matthew Pickering committed
290 291 292
                 -> TcType              -- ^ Pattern type
                 -> [Name]              -- ^ Selector names
                 -- ^ Whether fields, empty if not record PatSyn
293
                 -> TcM (LHsBinds Id, TcGblEnv)
294 295 296
tc_patsyn_finish lname dir is_infix lpat'
                 (univ_tvs, univ_bndrs, req_theta, req_ev_binds, req_dicts)
                 (ex_tvs, ex_bndrs, ex_tys, prov_theta, prov_dicts)
297
                 (args, arg_tys)
Matthew Pickering's avatar
Matthew Pickering committed
298
                 pat_ty field_labels
299 300
  = do { -- Zonk everything.  We are about to build a final PatSyn
         -- so there had better be no unification variables in there
301 302
         univ_tvs'    <- mapMaybeM (zonkQuantifiedTyVar False) univ_tvs
       ; ex_tvs'      <- mapMaybeM (zonkQuantifiedTyVar False) ex_tvs
Simon Peyton Jones's avatar
Simon Peyton Jones committed
303 304
                         -- ToDo: The False means that we behave here as if
                         -- -XPolyKinds was always on, which isn't right.
305 306 307 308 309 310 311 312 313 314 315
       ; prov_theta'  <- zonkTcTypes prov_theta
       ; req_theta'   <- zonkTcTypes req_theta
       ; pat_ty'      <- zonkTcType pat_ty
       ; arg_tys'     <- zonkTcTypes arg_tys

       ; let (env1, univ_tvs) = tidyTyCoVarBndrs emptyTidyEnv univ_tvs'
             (env2, ex_tvs)   = tidyTyCoVarBndrs env1 ex_tvs'
             req_theta  = tidyTypes env2 req_theta'
             prov_theta = tidyTypes env2 prov_theta'
             arg_tys    = tidyTypes env2 arg_tys'
             pat_ty     = tidyType  env2 pat_ty'
316

317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334
          -- We need to update the univ and ex binders after zonking.
          -- But zonking may have defaulted some erstwhile binders,
          -- so we need to make sure the tyvars and tybinders remain
          -- lined up
       ; let update_binders :: [TyVar] -> [TcTyBinder] -> [TyBinder]
             update_binders [] _ = []
             update_binders all_tvs@(tv:tvs) (bndr:bndrs)
               | tv == bndr_var
               = mkNamedBinder (binderVisibility bndr) tv : update_binders tvs bndrs
               | otherwise
               = update_binders all_tvs bndrs
               where
                 bndr_var = binderVar "tc_patsyn_finish" bndr
             update_binders tvs _ = pprPanic "tc_patsyn_finish" (ppr lname $$ ppr tvs)

             univ_bndrs' = update_binders univ_tvs univ_bndrs
             ex_bndrs'   = update_binders ex_tvs   ex_bndrs

335
       ; traceTc "tc_patsyn_finish {" $
336
           ppr (unLoc lname) $$ ppr (unLoc lpat') $$
337 338
           ppr (univ_tvs, univ_bndrs', req_theta, req_ev_binds, req_dicts) $$
           ppr (ex_tvs, ex_bndrs', prov_theta, prov_dicts) $$
339 340
           ppr args $$
           ppr arg_tys $$
341
           ppr pat_ty
342 343

       -- Make the 'matcher'
344
       ; (matcher_id, matcher_bind) <- tcPatSynMatcher lname lpat'
345
                                         (univ_tvs, req_theta, req_ev_binds, req_dicts)
346 347
                                         (ex_tvs, ex_tys, prov_theta, prov_dicts)
                                         (args, arg_tys)
Gergő Érdi's avatar
Gergő Érdi committed
348
                                         pat_ty
349

Matthew Pickering's avatar
Matthew Pickering committed
350

351
       -- Make the 'builder'
352 353 354
       ; builder_id <- mkPatSynBuilderId dir lname
                                         univ_bndrs' req_theta
                                         ex_bndrs'   prov_theta
Matthew Pickering's avatar
Matthew Pickering committed
355
                                         arg_tys pat_ty
Matthew Pickering's avatar
Matthew Pickering committed
356 357

         -- TODO: Make this have the proper information
358 359 360 361
       ; let mkFieldLabel name = FieldLabel { flLabel = occNameFS (nameOccName name)
                                            , flIsOverloaded = False
                                            , flSelector = name }
             field_labels' = map mkFieldLabel field_labels
Matthew Pickering's avatar
Matthew Pickering committed
362

Gergő Érdi's avatar
Gergő Érdi committed
363

364
       -- Make the PatSyn itself
Matthew Pickering's avatar
Matthew Pickering committed
365
       ; let patSyn = mkPatSyn (unLoc lname) is_infix
366 367
                        (univ_tvs, univ_bndrs', req_theta)
                        (ex_tvs, ex_bndrs', prov_theta)
368
                        arg_tys
Gergő Érdi's avatar
Gergő Érdi committed
369
                        pat_ty
370
                        matcher_id builder_id
Matthew Pickering's avatar
Matthew Pickering committed
371 372 373
                        field_labels'

       -- Selectors
374 375 376 377
       ; let rn_rec_sel_binds = mkPatSynRecSelBinds patSyn (patSynFieldLabels patSyn)
             tything = AConLike (PatSynCon patSyn)
       ; tcg_env <- tcExtendGlobalEnv [tything] $
                    tcRecSelBinds rn_rec_sel_binds
Matthew Pickering's avatar
Matthew Pickering committed
378

379
       ; traceTc "tc_patsyn_finish }" empty
380
       ; return (matcher_bind, tcg_env) }
381

Austin Seipp's avatar
Austin Seipp committed
382 383 384
{-
************************************************************************
*                                                                      *
385
         Constructing the "matcher" Id and its binding
Austin Seipp's avatar
Austin Seipp committed
386 387 388
*                                                                      *
************************************************************************
-}
389

390
tcPatSynMatcher :: Located Name
Gergő Érdi's avatar
Gergő Érdi committed
391
                -> LPat Id
392
                -> ([TcTyVar], ThetaType, TcEvBinds, [EvVar])
393 394
                -> ([TcTyVar], [TcType], ThetaType, [EvTerm])
                -> ([LHsExpr TcId], [TcType])
Gergő Érdi's avatar
Gergő Érdi committed
395
                -> TcType
396 397
                -> TcM ((Id, Bool), LHsBinds Id)
-- See Note [Matchers and builders for pattern synonyms] in PatSyn
398
tcPatSynMatcher (L loc name) lpat
399
                (univ_tvs, req_theta, req_ev_binds, req_dicts)
400 401
                (ex_tvs, ex_tys, prov_theta, prov_dicts)
                (args, arg_tys) pat_ty
402 403 404
  = do { rr_name <- newNameAt (mkTyVarOcc "rep") loc
       ; tv_name <- newNameAt (mkTyVarOcc "r")   loc
       ; let rr_tv    = mkTcTyVar rr_name runtimeRepTy (SkolemTv False)
405 406
             rr       = mkTyVarTy rr_tv
             res_tv   = mkTcTyVar tv_name  (tYPE rr) (SkolemTv False)
407
             is_unlifted = null args && null prov_dicts
408
             res_ty = mkTyVarTy res_tv
409 410 411
             (cont_args, cont_arg_tys)
               | is_unlifted = ([nlHsVar voidPrimId], [voidPrimTy])
               | otherwise   = (args,                 arg_tys)
412
             cont_ty = mkInvSigmaTy ex_tvs prov_theta $
413 414
                       mkFunTys cont_arg_tys res_ty

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
415
             fail_ty  = mkFunTy voidPrimTy res_ty
416

417
       ; matcher_name <- newImplicitBinder name mkMatcherOcc
418 419 420 421 422
       ; scrutinee    <- newSysLocalId (fsLit "scrut") pat_ty
       ; cont         <- newSysLocalId (fsLit "cont")  cont_ty
       ; fail         <- newSysLocalId (fsLit "fail")  fail_ty

       ; let matcher_tau   = mkFunTys [pat_ty, cont_ty, fail_ty] res_ty
423
             matcher_sigma = mkInvSigmaTy (rr_tv:res_tv:univ_tvs) req_theta matcher_tau
424
             matcher_id    = mkExportedVanillaId matcher_name matcher_sigma
425
                             -- See Note [Exported LocalIds] in Id
426

427 428
             inst_wrap = mkWpEvApps prov_dicts <.> mkWpTyApps ex_tys
             cont' = foldl nlHsApp (mkLHsWrap inst_wrap (nlHsVar cont)) cont_args
Gergő Érdi's avatar
Gergő Érdi committed
429

430
             fail' = nlHsApps fail [nlHsVar voidPrimId]
Gergő Érdi's avatar
Gergő Érdi committed
431

432
             args = map nlVarPat [scrutinee, cont, fail]
Gergő Érdi's avatar
Gergő Érdi committed
433 434
             lwpat = noLoc $ WildPat pat_ty
             cases = if isIrrefutableHsPat lpat
435 436 437
                     then [mkHsCaseAlt lpat  cont']
                     else [mkHsCaseAlt lpat  cont',
                           mkHsCaseAlt lwpat fail']
438
             body = mkLHsWrap (mkWpLet req_ev_binds) $
Gergő Érdi's avatar
Gergő Érdi committed
439 440
                    L (getLoc lpat) $
                    HsCase (nlHsVar scrutinee) $
441
                    MG{ mg_alts = L (getLoc lpat) cases
Gergő Érdi's avatar
Gergő Érdi committed
442 443
                      , mg_arg_tys = [pat_ty]
                      , mg_res_ty = res_ty
444
                      , mg_origin = Generated
Gergő Érdi's avatar
Gergő Érdi committed
445 446 447
                      }
             body' = noLoc $
                     HsLam $
448 449
                     MG{ mg_alts = noLoc [mkSimpleMatch LambdaExpr
                                                        args body]
Gergő Érdi's avatar
Gergő Érdi committed
450 451
                       , mg_arg_tys = [pat_ty, cont_ty, res_ty]
                       , mg_res_ty = res_ty
452
                       , mg_origin = Generated
Gergő Érdi's avatar
Gergő Érdi committed
453
                       }
454 455 456
             match = mkMatch (FunRhs (L loc name) Prefix) []
                             (mkHsLams (rr_tv:res_tv:univ_tvs)
                             req_dicts body')
457 458
                             (noLoc EmptyLocalBinds)
             mg = MG{ mg_alts = L (getLoc match) [match]
Gergő Érdi's avatar
Gergő Érdi committed
459 460
                    , mg_arg_tys = []
                    , mg_res_ty = res_ty
461
                    , mg_origin = Generated
Gergő Érdi's avatar
Gergő Érdi committed
462 463
                    }

464
       ; let bind = FunBind{ fun_id = L loc matcher_id
Gergő Érdi's avatar
Gergő Érdi committed
465 466 467
                           , fun_matches = mg
                           , fun_co_fn = idHsWrapper
                           , bind_fvs = emptyNameSet
468
                           , fun_tick = [] }
469
             matcher_bind = unitBag (noLoc bind)
Gergő Érdi's avatar
Gergő Érdi committed
470

471
       ; traceTc "tcPatSynMatcher" (ppr name $$ ppr (idType matcher_id))
Gergő Érdi's avatar
Gergő Érdi committed
472 473
       ; traceTc "tcPatSynMatcher" (ppr matcher_bind)

474 475
       ; return ((matcher_id, is_unlifted), matcher_bind) }

Matthew Pickering's avatar
Matthew Pickering committed
476
mkPatSynRecSelBinds :: PatSyn
477 478 479 480
                    -> [FieldLabel]  -- ^ Visible field labels
                    -> HsValBinds Name
mkPatSynRecSelBinds ps fields
  = ValBindsOut selector_binds sigs
481
  where
482 483
    (sigs, selector_binds) = unzip (map mkRecSel fields)
    mkRecSel fld_lbl = mkOneRecordSelector [PatSynCon ps] (RecSelPatSyn ps) fld_lbl
484 485 486 487 488 489

isUnidirectional :: HsPatSynDir a -> Bool
isUnidirectional Unidirectional          = True
isUnidirectional ImplicitBidirectional   = False
isUnidirectional ExplicitBidirectional{} = False

Austin Seipp's avatar
Austin Seipp committed
490 491 492
{-
************************************************************************
*                                                                      *
493
         Constructing the "builder" Id
Austin Seipp's avatar
Austin Seipp committed
494 495 496
*                                                                      *
************************************************************************
-}
497

498 499 500
mkPatSynBuilderId :: HsPatSynDir a -> Located Name
                  -> [TyBinder] -> ThetaType
                  -> [TyBinder] -> ThetaType
501
                  -> [Type] -> Type
502
                  -> TcM (Maybe (Id, Bool))
503 504
mkPatSynBuilderId dir (L _ name)
                  univ_bndrs req_theta ex_bndrs prov_theta
505
                  arg_tys pat_ty
506 507 508
  | isUnidirectional dir
  = return Nothing
  | otherwise
509
  = do { builder_name <- newImplicitBinder name mkBuilderOcc
510
       ; let theta          = req_theta ++ prov_theta
511
             need_dummy_arg = isUnliftedType pat_ty && null arg_tys && null theta
512
             builder_sigma  = add_void need_dummy_arg $
513 514 515 516 517
                              mkForAllTys univ_bndrs $
                              mkForAllTys ex_bndrs $
                              mkFunTys theta $
                              mkFunTys arg_tys $
                              pat_ty
518
             builder_id     = mkExportedVanillaId builder_name builder_sigma
Matthew Pickering's avatar
Matthew Pickering committed
519
              -- See Note [Exported LocalIds] in Id
520

521
       ; return (Just (builder_id, need_dummy_arg)) }
522
  where
523

524
tcPatSynBuilderBind :: PatSynBind Name Name
525 526
                    -> TcM (LHsBinds Id)
-- See Note [Matchers and builders for pattern synonyms] in PatSyn
527 528
tcPatSynBuilderBind (PSB { psb_id = L loc name, psb_def = lpat
                         , psb_dir = dir, psb_args = details })
529 530 531
  | isUnidirectional dir
  = return emptyBag

532
  | Left why <- mb_match_group       -- Can't invert the pattern
533
  = setSrcSpan (getLoc lpat) $ failWithTc $
534 535 536 537
    vcat [ hang (text "Invalid right-hand side of bidirectional pattern synonym"
                 <+> quotes (ppr name) <> colon)
              2 why
         , text "RHS pattern:" <+> ppr lpat ]
538

539
  | Right match_group <- mb_match_group  -- Bidirectional
540
  = do { patsyn <- tcLookupPatSyn name
541
       ; traceTc "tcPatSynBuilderBind {" $ ppr patsyn
542
       ; let Just (builder_id, need_dummy_arg) = patSynBuilder patsyn
543 544 545 546 547
                   -- Bidirectional, so patSynBuilder returns Just

             match_group' | need_dummy_arg = add_dummy_arg match_group
                          | otherwise      = match_group

548
             bind = FunBind { fun_id      = L loc (idName builder_id)
549 550 551 552 553
                            , fun_matches = match_group'
                            , fun_co_fn   = idHsWrapper
                            , bind_fvs    = placeHolderNamesTc
                            , fun_tick    = [] }

554
             sig = completeSigFromId (PatSynCtxt name) builder_id
555

556
       ; (builder_binds, _) <- tcPolyCheck emptyPragEnv sig (noLoc bind)
557 558
       ; traceTc "tcPatSynBuilderBind }" $ ppr builder_binds
       ; return builder_binds }
559 560

  | otherwise = panic "tcPatSynBuilderBind"  -- Both cases dealt with
561
  where
562
    mb_match_group
563
       = case dir of
564
           ExplicitBidirectional explicit_mg -> Right explicit_mg
565
           ImplicitBidirectional             -> fmap mk_mg (tcPatToExpr args lpat)
566
           Unidirectional -> panic "tcPatSynBuilderBind"
567 568

    mk_mg :: LHsExpr Name -> MatchGroup Name (LHsExpr Name)
569
    mk_mg body = mkMatchGroupName Generated [builder_match]
570
             where
571
               builder_args  = [L loc (VarPat (L loc n)) | L loc n <- args]
572 573 574
               builder_match = mkMatch (FunRhs (L loc name) Prefix)
                                       builder_args body
                                       (noLoc EmptyLocalBinds)
575 576

    args = case details of
577
              PrefixPatSyn args     -> args
578
              InfixPatSyn arg1 arg2 -> [arg1, arg2]
Matthew Pickering's avatar
Matthew Pickering committed
579
              RecordPatSyn args     -> map recordPatSynPatVar args
580

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
581 582
    add_dummy_arg :: MatchGroup Name (LHsExpr Name)
                  -> MatchGroup Name (LHsExpr Name)
583 584
    add_dummy_arg mg@(MG { mg_alts = L l [L loc match@(Match { m_pats = pats })] })
      = mg { mg_alts = L l [L loc (match { m_pats = nlWildPatName : pats })] }
585
    add_dummy_arg other_mg = pprPanic "add_dummy_arg" $
586
                             pprMatches other_mg
587

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
588 589 590
tcPatSynBuilderOcc :: PatSyn -> TcM (HsExpr TcId, TcSigmaType)
-- monadic only for failure
tcPatSynBuilderOcc ps
591
  | Just (builder_id, add_void_arg) <- builder
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
592 593 594 595 596 597 598
  , let builder_expr = HsVar (noLoc builder_id)
        builder_ty   = idType builder_id
  = return $
    if add_void_arg
    then ( HsApp (noLoc $ builder_expr) (nlHsVar voidPrimId)
         , tcFunResultTy builder_ty )
    else (builder_expr, builder_ty)
599 600

  | otherwise  -- Unidirectional
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
601
  = nonBidirectionalErr name
602 603 604
  where
    name    = patSynName ps
    builder = patSynBuilder ps
Gergő Érdi's avatar
Gergő Érdi committed
605

606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694
add_void :: Bool -> Type -> Type
add_void need_dummy_arg ty
  | need_dummy_arg = mkFunTy voidPrimTy ty
  | otherwise      = ty

tcPatToExpr :: [Located Name] -> LPat Name -> Either MsgDoc (LHsExpr Name)
-- Given a /pattern/, return an /expression/ that builds a value
-- that matches the pattern.  E.g. if the pattern is (Just [x]),
-- the expression is (Just [x]).  They look the same, but the
-- input uses constructors from HsPat and the output uses constructors
-- from HsExpr.
--
-- Returns (Left r) if the pattern is not invertible, for reason r.
-- See Note [Builder for a bidirectional pattern synonym]
tcPatToExpr args pat = go pat
  where
    lhsVars = mkNameSet (map unLoc args)

    -- Make a prefix con for prefix and infix patterns for simplicity
    mkPrefixConExpr :: Located Name -> [LPat Name] -> Either MsgDoc (HsExpr Name)
    mkPrefixConExpr lcon@(L loc _) pats
      = do { exprs <- mapM go pats
           ; return (foldl (\x y -> HsApp (L loc x) y)
                           (HsVar lcon) exprs) }

    mkRecordConExpr :: Located Name -> HsRecFields Name (LPat Name)
                    -> Either MsgDoc (HsExpr Name)
    mkRecordConExpr con fields
      = do { exprFields <- mapM go fields
           ; return (RecordCon con PlaceHolder noPostTcExpr exprFields) }

    go :: LPat Name -> Either MsgDoc (LHsExpr Name)
    go (L loc p) = L loc <$> go1 p

    go1 :: Pat Name -> Either MsgDoc (HsExpr Name)
    go1 (ConPatIn con info)
      = case info of
          PrefixCon ps  -> mkPrefixConExpr con ps
          InfixCon l r  -> mkPrefixConExpr con [l,r]
          RecCon fields -> mkRecordConExpr con fields

    go1 (SigPatIn pat _) = go1 (unLoc pat)
        -- See Note [Type signatures and the builder expression]

    go1 (VarPat (L l var))
        | var `elemNameSet` lhsVars
        = return $ HsVar (L l var)
        | otherwise
        = Left (quotes (ppr var) <+> text "is not bound by the LHS of the pattern synonym")
    go1 (ParPat pat)                = fmap HsPar $ go pat
    go1 (LazyPat pat)               = go1 (unLoc pat)
    go1 (BangPat pat)               = go1 (unLoc pat)
    go1 (PArrPat pats ptt)          = do { exprs <- mapM go pats
                                         ; return $ ExplicitPArr ptt exprs }
    go1 (ListPat pats ptt reb)      = do { exprs <- mapM go pats
                                         ; return $ ExplicitList ptt (fmap snd reb) exprs }
    go1 (TuplePat pats box _)       = do { exprs <- mapM go pats
                                         ; return $ ExplicitTuple
                                              (map (noLoc . Present) exprs) box }
    go1 (LitPat lit)                = return $ HsLit lit
    go1 (NPat (L _ n) mb_neg _ _)
        | Just neg <- mb_neg        = return $ unLoc $ nlHsSyntaxApps neg [noLoc (HsOverLit n)]
        | otherwise                 = return $ HsOverLit n
    go1 (ConPatOut{})               = panic "ConPatOut in output of renamer"
    go1 (SigPatOut{})               = panic "SigPatOut in output of renamer"
    go1 (CoPat{})                   = panic "CoPat in output of renamer"
    go1 p = Left (text "pattern" <+> quotes (ppr p) <+> text "is not invertible")

{- Note [Builder for a bidirectional pattern synonym]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For a bidirectional pattern synonym we need to produce an /expression/
that matches the supplied /pattern/, given values for the arguments
of the pattern synoymy.  For example
  pattern F x y = (Just x, [y])
The 'builder' for F looks like
  $builderF x y = (Just x, [y])

We can't always do this:
 * Some patterns aren't invertible; e.g. view patterns
      pattern F x = (reverse -> x:_)

 * The RHS pattern might bind more variables than the pattern
   synonym, so again we can't invert it
      pattern F x = (x,y)

 * Ditto wildcards
      pattern F x = (x,_)


695 696 697 698 699 700
Note [Redundant constraints for builder]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The builder can have redundant constraints, which are awkard to eliminate.
Consider
   pattern P = Just 34
To match against this pattern we need (Eq a, Num a).  But to build
701 702
(Just 34) we need only (Num a).  Fortunately instTcSigFromId sets
sig_warn_redundant to False.
703

Austin Seipp's avatar
Austin Seipp committed
704 705
************************************************************************
*                                                                      *
706
         Helper functions
Austin Seipp's avatar
Austin Seipp committed
707 708
*                                                                      *
************************************************************************
709

710 711
Note [As-patterns in pattern synonym definitions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
712 713 714
The rationale for rejecting as-patterns in pattern synonym definitions
is that an as-pattern would introduce nonindependent pattern synonym
arguments, e.g. given a pattern synonym like:
715 716 717 718 719 720

        pattern K x y = x@(Just y)

one could write a nonsensical function like

        f (K Nothing x) = ...
Gergő Érdi's avatar
Gergő Érdi committed
721

722 723
or
        g (K (Just True) False) = ...
724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743

Note [Type signatures and the builder expression]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
   pattern L x = Left x :: Either [a] [b]

In tc{Infer/Check}PatSynDecl we will check that the pattern has the
specified type.  We check the pattern *as a pattern*, so the type
signature is a pattern signature, and so brings 'a' and 'b' into
scope.  But we don't have a way to bind 'a, b' in the LHS, as we do
'x', say.  Nevertheless, the sigature may be useful to constrain
the type.

When making the binding for the *builder*, though, we don't want
  $buildL x = Left x :: Either [a] [b]
because that wil either mean (forall a b. Either [a] [b]), or we'll
get a complaint that 'a' and 'b' are out of scope. (Actually the
latter; Trac #9867.)  No, the job of the signature is done, so when
converting the pattern to an expression (for the builder RHS) we
simply discard the signature.
Matthew Pickering's avatar
Matthew Pickering committed
744 745 746 747 748 749 750 751

Note [Record PatSyn Desugaring]
-------------------------------
It is important that prov_theta comes before req_theta as this ordering is used
when desugaring record pattern synonym updates.

Any change to this ordering should make sure to change deSugar/DsExpr.hs if you
want to avoid difficult to decipher core lint errors!
752
 -}
753

754 755 756 757 758 759 760 761 762 763
tcCheckPatSynPat :: LPat Name -> TcM ()
tcCheckPatSynPat = go
  where
    go :: LPat Name -> TcM ()
    go = addLocM go1

    go1 :: Pat Name -> TcM ()
    go1   (ConPatIn _ info)   = mapM_ go (hsConPatArgs info)
    go1   VarPat{}            = return ()
    go1   WildPat{}           = return ()
764
    go1 p@(AsPat _ _)         = asPatInPatSynErr p
765 766 767 768 769 770
    go1   (LazyPat pat)       = go pat
    go1   (ParPat pat)        = go pat
    go1   (BangPat pat)       = go pat
    go1   (PArrPat pats _)    = mapM_ go pats
    go1   (ListPat pats _ _)  = mapM_ go pats
    go1   (TuplePat pats _ _) = mapM_ go pats
771 772
    go1   LitPat{}            = return ()
    go1   NPat{}              = return ()
773 774 775 776 777 778 779 780
    go1   (SigPatIn pat _)    = go pat
    go1   (ViewPat _ pat _)   = go pat
    go1 p@SplicePat{}         = thInPatSynErr p
    go1 p@NPlusKPat{}         = nPlusKPatInPatSynErr p
    go1   ConPatOut{}         = panic "ConPatOut in output of renamer"
    go1   SigPatOut{}         = panic "SigPatOut in output of renamer"
    go1   CoPat{}             = panic "CoPat in output of renamer"

781
asPatInPatSynErr :: (OutputableBndrId name) => Pat name -> TcM a
782 783
asPatInPatSynErr pat
  = failWithTc $
784
    hang (text "Pattern synonym definition cannot contain as-patterns (@):")
785 786
       2 (ppr pat)

787
thInPatSynErr :: (OutputableBndrId name) => Pat name -> TcM a
788 789
thInPatSynErr pat
  = failWithTc $
790
    hang (text "Pattern synonym definition cannot contain Template Haskell:")
791 792
       2 (ppr pat)

793
nPlusKPatInPatSynErr :: (OutputableBndrId name) => Pat name -> TcM a
794 795
nPlusKPatInPatSynErr pat
  = failWithTc $
796
    hang (text "Pattern synonym definition cannot contain n+k-pattern:")
797 798
       2 (ppr pat)

Matthew Pickering's avatar
Matthew Pickering committed
799 800
nonBidirectionalErr :: Outputable name => name -> TcM a
nonBidirectionalErr name = failWithTc $
801 802
    text "non-bidirectional pattern synonym"
    <+> quotes (ppr name) <+> text "used in an expression"
Matthew Pickering's avatar
Matthew Pickering committed
803

804 805 806 807 808 809
-- Walk the whole pattern and for all ConPatOuts, collect the
-- existentially-bound type variables and evidence binding variables.
--
-- These are used in computing the type of a pattern synonym and also
-- in generating matcher functions, since success continuations need
-- to be passed these pattern-bound evidences.
810 811 812 813 814 815 816 817
tcCollectEx
  :: LPat Id
  -> ( ([Var], VarSet) -- Existentially-bound type variables as a
                       -- deterministically ordered list and a set.
                       -- See Note [Deterministic FV] in FV
     , [EvVar]
     )
tcCollectEx pat = let (fv, evs) = go pat in (fvVarListVarSet fv, evs)
Gergő Érdi's avatar
Gergő Érdi committed
818
  where
819
    go :: LPat Id -> (FV, [EvVar])
Gergő Érdi's avatar
Gergő Érdi committed
820 821
    go = go1 . unLoc

822
    go1 :: Pat Id -> (FV, [EvVar])
Gergő Érdi's avatar
Gergő Érdi committed
823 824 825 826
    go1 (LazyPat p)         = go p
    go1 (AsPat _ p)         = go p
    go1 (ParPat p)          = go p
    go1 (BangPat p)         = go p
827 828 829
    go1 (ListPat ps _ _)    = mergeMany . map go $ ps
    go1 (TuplePat ps _ _)   = mergeMany . map go $ ps
    go1 (PArrPat ps _)      = mergeMany . map go $ ps
Gergő Érdi's avatar
Gergő Érdi committed
830
    go1 (ViewPat _ p _)     = go p
831
    go1 con@ConPatOut{}     = merge (FV.mkFVs (pat_tvs con), pat_dicts con) $
Gergő Érdi's avatar
Gergő Érdi committed
832 833 834
                                 goConDetails $ pat_args con
    go1 (SigPatOut p _)     = go p
    go1 (CoPat _ p _)       = go1 p
835
    go1 (NPlusKPat n k _ geq subtract _)
Gergő Érdi's avatar
Gergő Érdi committed
836
      = pprPanic "TODO: NPlusKPat" $ ppr n $$ ppr k $$ ppr geq $$ ppr subtract
837
    go1 _                   = empty
Gergő Érdi's avatar
Gergő Érdi committed
838

839 840 841
    goConDetails :: HsConPatDetails Id -> (FV, [EvVar])
    goConDetails (PrefixCon ps) = mergeMany . map go $ ps
    goConDetails (InfixCon p1 p2) = go p1 `merge` go p2
Gergő Érdi's avatar
Gergő Érdi committed
842
    goConDetails (RecCon HsRecFields{ rec_flds = flds })
843
      = mergeMany . map goRecFd $ flds
Gergő Érdi's avatar
Gergő Érdi committed
844

845
    goRecFd :: LHsRecField Id (LPat Id) -> (FV, [EvVar])
846
    goRecFd (L _ HsRecField{ hsRecFieldArg = p }) = go p
847 848 849 850

    merge (vs1, evs1) (vs2, evs2) = (vs1 `unionFV` vs2, evs1 ++ evs2)
    mergeMany = foldr merge empty
    empty = (emptyFV, [])