compiler/typecheck/TcPatSyn.lhs

   1 %
   2 % (c) The University of Glasgow 2006
   3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   4 %
   5 \section[TcPatSyn]{Typechecking pattern synonym declarations}
   6
   7 \begin{code}
   8 {-# LANGUAGE CPP #-}
   9
  10 module TcPatSyn (tcPatSynDecl) where
  11
  12 import HsSyn
  13 import TcPat
  14 import TcRnMonad
  15 import TcEnv
  16 import TcMType
  17 import TysPrim
  18 import Name
  19 import SrcLoc
  20 import PatSyn
  21 import NameSet
  22 import Panic
  23 import Outputable
  24 import FastString
  25 import Var
  26 import Id
  27 import TcBinds
  28 import BasicTypes
  29 import TcSimplify
  30 import TcType
  31 import VarSet
  32 import Data.Monoid
  33 import Bag
  34 import TcEvidence
  35 import BuildTyCl
  36 import TypeRep
  37
  38 #include "HsVersions.h"
  39 \end{code}
  40
  41 \begin{code}
  42 tcPatSynDecl :: Located Name
  43              -> HsPatSynDetails (Located Name)
  44              -> LPat Name
  45              -> HsPatSynDir Name
  46              -> TcM (PatSyn, LHsBinds Id)
  47 tcPatSynDecl lname@(L _ name) details lpat dir
  48   = do { traceTc "tcPatSynDecl {" $ ppr name $$ ppr lpat
  49        ; tcCheckPatSynPat lpat
  50        ; pat_ty <- newFlexiTyVarTy openTypeKind
  51
  52        ; let (arg_names, is_infix) = case details of
  53                  PrefixPatSyn names      -> (map unLoc names, False)
  54                  InfixPatSyn name1 name2 -> (map unLoc [name1, name2], True)
  55        ; ((lpat', args), wanted) <- captureConstraints       $
  56                                     tcPat PatSyn lpat pat_ty $
  57                                     mapM tcLookupId arg_names
  58        ; let named_taus = (name, pat_ty):map (\arg -> (getName arg, varType arg)) args
  59
  60        ; traceTc "tcPatSynDecl::wanted" (ppr named_taus $$ ppr wanted)
  61        ; (qtvs, req_dicts, _mr_bites, ev_binds) <- simplifyInfer True False named_taus wanted
  62
  63        ; (ex_vars, prov_dicts) <- tcCollectEx lpat'
  64        ; let univ_tvs   = filter (not . (`elemVarSet` ex_vars)) qtvs
  65              ex_tvs     = varSetElems ex_vars
  66              prov_theta = map evVarPred prov_dicts
  67              req_theta  = map evVarPred req_dicts
  68
  69        ; univ_tvs   <- mapM zonkQuantifiedTyVar univ_tvs
  70        ; ex_tvs     <- mapM zonkQuantifiedTyVar ex_tvs
  71        ; prov_theta <- zonkTcThetaType prov_theta
  72        ; req_theta  <- zonkTcThetaType req_theta
  73        ; pat_ty     <- zonkTcType pat_ty
  74        ; args       <- mapM zonkId args
  75
  76        ; traceTc "tcPatSynDecl: ex" (ppr ex_tvs $$
  77                                      ppr prov_theta $$
  78                                      ppr prov_dicts)
  79        ; traceTc "tcPatSynDecl: univ" (ppr univ_tvs $$
  80                                        ppr req_theta $$
  81                                        ppr req_dicts $$
  82                                        ppr ev_binds)
  83
  84        ; let theta = prov_theta ++ req_theta
  85
  86        ; traceTc "tcPatSynDecl: type" (ppr name $$
  87                                        ppr univ_tvs $$
  88                                        ppr (map varType args) $$
  89                                        ppr pat_ty)
  90
  91        ; (matcher_id, matcher_bind) <- tcPatSynMatcher lname lpat' args
  92                                          univ_tvs ex_tvs
  93                                          ev_binds
  94                                          prov_dicts req_dicts
  95                                          prov_theta req_theta
  96                                          pat_ty
  97        ; m_wrapper <- tcPatSynWrapper lname lpat dir args
  98                                       univ_tvs ex_tvs theta pat_ty
  99        ; let binds = matcher_bind `unionBags` maybe emptyBag snd m_wrapper
 100
 101        ; traceTc "tcPatSynDecl }" $ ppr name
 102        ; let patSyn = mkPatSyn name is_infix
 103                         (map varType args)
 104                         univ_tvs ex_tvs
 105                         prov_theta req_theta
 106                         pat_ty
 107                         matcher_id (fmap fst m_wrapper)
 108        ; return (patSyn, binds) }
 109
 110 \end{code}
 111
 112
 113 \begin{code}
 114 tcPatSynMatcher :: Located Name
 115                 -> LPat Id
 116                 -> [Var]
 117                 -> [TcTyVar] -> [TcTyVar]
 118                 -> TcEvBinds
 119                 -> [EvVar] -> [EvVar]
 120                 -> ThetaType -> ThetaType
 121                 -> TcType
 122                 -> TcM (Id, LHsBinds Id)
 123 -- See Note [Matchers and wrappers for pattern synonyms] in PatSyn
 124 tcPatSynMatcher (L loc name) lpat args univ_tvs ex_tvs ev_binds prov_dicts req_dicts prov_theta req_theta pat_ty
 125   = do { res_tv <- zonkQuantifiedTyVar =<< newFlexiTyVar liftedTypeKind
 126        ; matcher_name <- newImplicitBinder name mkMatcherOcc
 127        ; let res_ty = TyVarTy res_tv
 128              cont_ty = mkSigmaTy ex_tvs prov_theta $
 129                        mkFunTys (map varType args) res_ty
 130
 131        ; let matcher_tau = mkFunTys [pat_ty, cont_ty, res_ty] res_ty
 132              matcher_sigma = mkSigmaTy (res_tv:univ_tvs) req_theta matcher_tau
 133              matcher_id = mkVanillaGlobal matcher_name matcher_sigma
 134
 135        ; traceTc "tcPatSynMatcher" (ppr name $$ ppr (idType matcher_id))
 136        ; let matcher_lid = L loc matcher_id
 137
 138        ; scrutinee <- mkId "scrut" pat_ty
 139        ; cont <- mkId "cont" cont_ty
 140        ; let cont' = nlHsApps cont $ map nlHsVar (ex_tvs ++ prov_dicts ++ args)
 141        ; fail <- mkId "fail" res_ty
 142        ; let fail' = nlHsVar fail
 143
 144
 145        ; let args = map nlVarPat [scrutinee, cont, fail]
 146              lwpat = noLoc $ WildPat pat_ty
 147              cases = if isIrrefutableHsPat lpat
 148                      then [mkSimpleHsAlt lpat  cont']
 149                      else [mkSimpleHsAlt lpat  cont',
 150                            mkSimpleHsAlt lwpat fail']
 151              body = mkLHsWrap (mkWpLet ev_binds) $
 152                     L (getLoc lpat) $
 153                     HsCase (nlHsVar scrutinee) $
 154                     MG{ mg_alts = cases
 155                       , mg_arg_tys = [pat_ty]
 156                       , mg_res_ty = res_ty
 157                       , mg_origin = Generated
 158                       }
 159              body' = noLoc $
 160                      HsLam $
 161                      MG{ mg_alts = [mkSimpleMatch args body]
 162                        , mg_arg_tys = [pat_ty, cont_ty, res_ty]
 163                        , mg_res_ty = res_ty
 164                        , mg_origin = Generated
 165                        }
 166
 167              match = mkMatch [] (mkHsLams (res_tv:univ_tvs) req_dicts body') EmptyLocalBinds
 168              mg = MG{ mg_alts = [match]
 169                     , mg_arg_tys = []
 170                     , mg_res_ty = res_ty
 171                     , mg_origin = Generated
 172                     }
 173
 174        ; let bind = FunBind{ fun_id = matcher_lid
 175                            , fun_infix = False
 176                            , fun_matches = mg
 177                            , fun_co_fn = idHsWrapper
 178                            , bind_fvs = emptyNameSet
 179                            , fun_tick = Nothing }
 180              matcher_bind = unitBag (noLoc bind)
 181
 182        ; traceTc "tcPatSynMatcher" (ppr matcher_bind)
 183
 184        ; return (matcher_id, matcher_bind) }
 185   where
 186     mkId s ty = do
 187         name <- newName . mkVarOccFS . fsLit $ s
 188         return $ mkLocalId name ty
 189
 190 tcPatSynWrapper :: Located Name
 191                 -> LPat Name
 192                 -> HsPatSynDir Name
 193                 -> [Var]
 194                 -> [TyVar] -> [TyVar]
 195                 -> ThetaType
 196                 -> TcType
 197                 -> TcM (Maybe (Id, LHsBinds Id))
 198 -- See Note [Matchers and wrappers for pattern synonyms] in PatSyn
 199 tcPatSynWrapper lname lpat dir args univ_tvs ex_tvs theta pat_ty
 200   = do { let argNames = mkNameSet (map Var.varName args)
 201        ; case (dir, tcPatToExpr argNames lpat) of
 202            (Unidirectional, _) ->
 203                return Nothing
 204            (ImplicitBidirectional, Nothing) ->
 205                cannotInvertPatSynErr lpat
 206            (ImplicitBidirectional, Just lexpr) ->
 207                fmap Just $ tc_pat_syn_wrapper_from_expr lname lexpr args univ_tvs ex_tvs theta pat_ty }
 208
 209 tc_pat_syn_wrapper_from_expr :: Located Name
 210                              -> LHsExpr Name
 211                              -> [Var]
 212                              -> [TyVar] -> [TyVar]
 213                              -> ThetaType
 214                              -> Type
 215                              -> TcM (Id, LHsBinds Id)
 216 tc_pat_syn_wrapper_from_expr (L loc name) lexpr args univ_tvs ex_tvs theta pat_ty
 217   = do { let qtvs = univ_tvs ++ ex_tvs
 218        ; (subst, wrapper_tvs) <- tcInstSkolTyVars qtvs
 219        ; let wrapper_theta = substTheta subst theta
 220              pat_ty' = substTy subst pat_ty
 221              args' = map (\arg -> setVarType arg $ substTy subst (varType arg)) args
 222              wrapper_tau = mkFunTys (map varType args') pat_ty'
 223              wrapper_sigma = mkSigmaTy wrapper_tvs wrapper_theta wrapper_tau
 224
 225        ; wrapper_name <- newImplicitBinder name mkDataConWrapperOcc
 226        ; let wrapper_lname = L loc wrapper_name
 227              wrapper_id = mkVanillaGlobal wrapper_name wrapper_sigma
 228
 229        ; let wrapper_args = map (noLoc . VarPat . Var.varName) args'
 230              wrapper_match = mkMatch wrapper_args lexpr EmptyLocalBinds
 231              bind = mkTopFunBind Generated wrapper_lname [wrapper_match]
 232              lbind = noLoc bind
 233        ; let sig = TcSigInfo{ sig_id = wrapper_id
 234                             , sig_tvs = map (\tv -> (Nothing, tv)) wrapper_tvs
 235                             , sig_theta = wrapper_theta
 236                             , sig_tau = wrapper_tau
 237                             , sig_loc = loc
 238                             }
 239        ; (wrapper_binds, _, _) <- tcPolyCheck NonRecursive (const []) sig lbind
 240        ; traceTc "tcPatSynDecl wrapper" $ ppr wrapper_binds
 241        ; traceTc "tcPatSynDecl wrapper type" $ ppr (varType wrapper_id)
 242        ; return (wrapper_id, wrapper_binds) }
 243
 244 \end{code}
 245
 246 Note [As-patterns in pattern synonym definitions]
 247 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 248
 249 The rationale for rejecting as-patterns in pattern synonym definitions
 250 is that an as-pattern would introduce nonindependent pattern synonym
 251 arguments, e.g. given a pattern synonym like:
 252
 253         pattern K x y = x@(Just y)
 254
 255 one could write a nonsensical function like
 256
 257         f (K Nothing x) = ...
 258
 259 or
 260         g (K (Just True) False) = ...
 261
 262 \begin{code}
 263 tcCheckPatSynPat :: LPat Name -> TcM ()
 264 tcCheckPatSynPat = go
 265   where
 266     go :: LPat Name -> TcM ()
 267     go = addLocM go1
 268
 269     go1 :: Pat Name -> TcM ()
 270     go1   (ConPatIn _ info)   = mapM_ go (hsConPatArgs info)
 271     go1   VarPat{}            = return ()
 272     go1   WildPat{}           = return ()
 273     go1 p@(AsPat _ _)         = asPatInPatSynErr p
 274     go1   (LazyPat pat)       = go pat
 275     go1   (ParPat pat)        = go pat
 276     go1   (BangPat pat)       = go pat
 277     go1   (PArrPat pats _)    = mapM_ go pats
 278     go1   (ListPat pats _ _)  = mapM_ go pats
 279     go1   (TuplePat pats _ _) = mapM_ go pats
 280     go1   LitPat{}            = return ()
 281     go1   NPat{}              = return ()
 282     go1   (SigPatIn pat _)    = go pat
 283     go1   (ViewPat _ pat _)   = go pat
 284     go1 p@SplicePat{}         = thInPatSynErr p
 285     go1 p@QuasiQuotePat{}     = thInPatSynErr p
 286     go1 p@NPlusKPat{}         = nPlusKPatInPatSynErr p
 287     go1   ConPatOut{}         = panic "ConPatOut in output of renamer"
 288     go1   SigPatOut{}         = panic "SigPatOut in output of renamer"
 289     go1   CoPat{}             = panic "CoPat in output of renamer"
 290
 291 asPatInPatSynErr :: OutputableBndr name => Pat name -> TcM a
 292 asPatInPatSynErr pat
 293   = failWithTc $
 294     hang (ptext (sLit "Pattern synonym definition cannot contain as-patterns (@):"))
 295        2 (ppr pat)
 296
 297 thInPatSynErr :: OutputableBndr name => Pat name -> TcM a
 298 thInPatSynErr pat
 299   = failWithTc $
 300     hang (ptext (sLit "Pattern synonym definition cannot contain Template Haskell:"))
 301        2 (ppr pat)
 302
 303 nPlusKPatInPatSynErr :: OutputableBndr name => Pat name -> TcM a
 304 nPlusKPatInPatSynErr pat
 305   = failWithTc $
 306     hang (ptext (sLit "Pattern synonym definition cannot contain n+k-pattern:"))
 307        2 (ppr pat)
 308
 309 tcPatToExpr :: NameSet -> LPat Name -> Maybe (LHsExpr Name)
 310 tcPatToExpr lhsVars = go
 311   where
 312     go :: LPat Name -> Maybe (LHsExpr Name)
 313     go (L loc (ConPatIn conName info))
 314       = do
 315           { let con = L loc (HsVar (unLoc conName))
 316           ; exprs <- mapM go (hsConPatArgs info)
 317           ; return $ foldl (\x y -> L loc (HsApp x y)) con exprs }
 318     go (L loc p) = fmap (L loc) $ go1 p
 319
 320     go1 :: Pat Name -> Maybe (HsExpr Name)
 321     go1   (VarPat var)
 322       | var `elemNameSet` lhsVars  = return $ HsVar var
 323       | otherwise                  = Nothing
 324     go1   (LazyPat pat)            = fmap HsPar $ go pat
 325     go1   (ParPat pat)             = fmap HsPar $ go pat
 326     go1   (BangPat pat)            = fmap HsPar $ go pat
 327     go1   (PArrPat pats ptt)
 328       = do { exprs <- mapM go pats
 329            ; return $ ExplicitPArr ptt exprs }
 330     go1   (ListPat pats ptt reb)
 331       = do { exprs <- mapM go pats
 332            ; return $ ExplicitList ptt (fmap snd reb) exprs }
 333     go1   (TuplePat pats box _)
 334       = do { exprs <- mapM go pats
 335            ; return (ExplicitTuple (map Present exprs) box)
 336            }
 337     go1   (LitPat lit)             = return $ HsLit lit
 338     go1   (NPat n Nothing _)       = return $ HsOverLit n
 339     go1   (NPat n (Just neg) _)    = return $ noLoc neg `HsApp` noLoc (HsOverLit n)
 340     go1   (SigPatIn pat (HsWB ty _ _))
 341       = do { expr <- go pat
 342            ; return $ ExprWithTySig expr ty }
 343     go1   (ConPatOut{})            = panic "ConPatOut in output of renamer"
 344     go1   (SigPatOut{})            = panic "SigPatOut in output of renamer"
 345     go1   (CoPat{})                = panic "CoPat in output of renamer"
 346     go1   _                        = Nothing
 347
 348 cannotInvertPatSynErr :: OutputableBndr name => LPat name -> TcM a
 349 cannotInvertPatSynErr (L loc pat)
 350   = setSrcSpan loc $ failWithTc $
 351     hang (ptext (sLit "Right-hand side of bidirectional pattern synonym cannot be used as an expression"))
 352        2 (ppr pat)
 353
 354 -- Walk the whole pattern and for all ConPatOuts, collect the
 355 -- existentially-bound type variables and evidence binding variables.
 356 --
 357 -- These are used in computing the type of a pattern synonym and also
 358 -- in generating matcher functions, since success continuations need
 359 -- to be passed these pattern-bound evidences.
 360 tcCollectEx :: LPat Id -> TcM (TyVarSet, [EvVar])
 361 tcCollectEx = return . go
 362   where
 363     go :: LPat Id -> (TyVarSet, [EvVar])
 364     go = go1 . unLoc
 365
 366     go1 :: Pat Id -> (TyVarSet, [EvVar])
 367     go1 (LazyPat p)         = go p
 368     go1 (AsPat _ p)         = go p
 369     go1 (ParPat p)          = go p
 370     go1 (BangPat p)         = go p
 371     go1 (ListPat ps _ _)    = mconcat . map go $ ps
 372     go1 (TuplePat ps _ _)   = mconcat . map go $ ps
 373     go1 (PArrPat ps _)      = mconcat . map go $ ps
 374     go1 (ViewPat _ p _)     = go p
 375     go1 (QuasiQuotePat qq)  = pprPanic "TODO: tcInstPatSyn QuasiQuotePat" $ ppr qq
 376     go1 con@ConPatOut{}     = mappend (mkVarSet (pat_tvs con), pat_dicts con) $
 377                                  goConDetails $ pat_args con
 378     go1 (SigPatOut p _)     = go p
 379     go1 (CoPat _ p _)       = go1 p
 380     go1 (NPlusKPat n k geq subtract)
 381       = pprPanic "TODO: NPlusKPat" $ ppr n $$ ppr k $$ ppr geq $$ ppr subtract
 382     go1 _                   = mempty
 383
 384     goConDetails :: HsConPatDetails Id -> (TyVarSet, [EvVar])
 385     goConDetails (PrefixCon ps) = mconcat . map go $ ps
 386     goConDetails (InfixCon p1 p2) = go p1 `mappend` go p2
 387     goConDetails (RecCon HsRecFields{ rec_flds = flds })
 388       = mconcat . map goRecFd $ flds
 389
 390     goRecFd :: HsRecField Id (LPat Id) -> (TyVarSet, [EvVar])
 391     goRecFd HsRecField{ hsRecFieldArg = p } = go p
 392
 393 \end{code}