-checkPattern :: SrcLoc -> RdrNameHsExpr -> P RdrNamePat
-checkPattern loc e = setSrcLocP loc (checkPat e [])
-
-checkPatterns :: SrcLoc -> [RdrNameHsExpr] -> P [RdrNamePat]
-checkPatterns loc es = mapP (checkPattern loc) es
-
-checkPat :: RdrNameHsExpr -> [RdrNamePat] -> P RdrNamePat
-checkPat (HsVar c) args | isRdrDataCon c = returnP (ConPatIn c (PrefixCon args))
-checkPat (HsApp f x) args =
- checkPat x [] `thenP` \x ->
- checkPat f (x:args)
-checkPat e [] = case e of
- EWildPat -> returnP (WildPat placeHolderType)
- HsVar x | isQual x -> parseError ("Qualified variable in pattern: " ++ showRdrName x)
- | otherwise -> returnP (VarPat x)
- HsLit l -> returnP (LitPat l)
- HsOverLit l -> returnP (NPatIn l Nothing)
- ELazyPat e -> checkPat e [] `thenP` (returnP . LazyPat)
- EAsPat n e -> checkPat e [] `thenP` (returnP . AsPat n)
- ExprWithTySig e t -> checkPat e [] `thenP` \e ->
- -- Pattern signatures are parsed as sigtypes,
- -- but they aren't explicit forall points. Hence
- -- we have to remove the implicit forall here.
- let t' = case t of
- HsForAllTy Nothing [] ty -> ty
- other -> other
- in
- returnP (SigPatIn e t')
-
- -- Translate out NegApps of literals in patterns. We negate
- -- the Integer here, and add back the call to 'negate' when
- -- we typecheck the pattern.
- -- NB. Negative *primitive* literals are already handled by
- -- RdrHsSyn.mkHsNegApp
- NegApp (HsOverLit lit) neg -> returnP (NPatIn lit (Just neg))
-
- OpApp (HsVar n) (HsVar plus) _ (HsOverLit lit@(HsIntegral _ _))
- | plus == plus_RDR
- -> returnP (mkNPlusKPat n lit)
- where
- plus_RDR = mkUnqual varName FSLIT("+") -- Hack
-
- OpApp l op fix r -> checkPat l [] `thenP` \l ->
- checkPat r [] `thenP` \r ->
- case op of
- HsVar c | isDataOcc (rdrNameOcc c)
- -> returnP (ConPatIn c (InfixCon l r))
- _ -> patFail
-
- HsPar e -> checkPat e [] `thenP` (returnP . ParPat)
- ExplicitList _ es -> mapP (\e -> checkPat e []) es `thenP` \ps ->
- returnP (ListPat ps placeHolderType)
- ExplicitPArr _ es -> mapP (\e -> checkPat e []) es `thenP` \ps ->
- returnP (PArrPat ps placeHolderType)
-
- ExplicitTuple es b -> mapP (\e -> checkPat e []) es `thenP` \ps ->
- returnP (TuplePat ps b)
-
- RecordCon c fs -> mapP checkPatField fs `thenP` \fs ->
- returnP (ConPatIn c (RecCon fs))
+checkPattern :: LHsExpr RdrName -> P (LPat RdrName)
+checkPattern e = checkLPat e
+
+checkPatterns :: [LHsExpr RdrName] -> P [LPat RdrName]
+checkPatterns es = mapM checkPattern es
+
+checkLPat :: LHsExpr RdrName -> P (LPat RdrName)
+checkLPat e@(L l _) = checkPat l e []
+
+checkPat :: SrcSpan -> LHsExpr RdrName -> [LPat RdrName] -> P (LPat RdrName)
+checkPat loc (L l (HsVar c)) args
+ | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args)))
+checkPat loc (L _ (HsApp f x)) args = do
+ x <- checkLPat x
+ checkPat loc f (x:args)
+checkPat loc (L _ e) [] = do
+ p <- checkAPat loc e
+ return (L loc p)
+checkPat loc pat _some_args
+ = patFail loc
+
+checkAPat loc e = case e of
+ EWildPat -> return (WildPat placeHolderType)
+ HsVar x | isQual x -> parseError loc ("Qualified variable in pattern: "
+ ++ showRdrName x)
+ | otherwise -> return (VarPat x)
+ HsLit l -> return (LitPat l)
+
+ -- Overloaded numeric patterns (e.g. f 0 x = x)
+ -- Negation is recorded separately, so that the literal is zero or +ve
+ -- NB. Negative *primitive* literals are already handled by
+ -- RdrHsSyn.mkHsNegApp
+ HsOverLit pos_lit -> return (mkNPat pos_lit Nothing)
+ NegApp (L _ (HsOverLit pos_lit)) _
+ -> return (mkNPat pos_lit (Just noSyntaxExpr))
+
+ ELazyPat e -> checkLPat e >>= (return . LazyPat)
+ EAsPat n e -> checkLPat e >>= (return . AsPat n)
+ ExprWithTySig e t -> checkLPat e >>= \e ->
+ -- Pattern signatures are parsed as sigtypes,
+ -- but they aren't explicit forall points. Hence
+ -- we have to remove the implicit forall here.
+ let t' = case t of
+ L _ (HsForAllTy Implicit _ (L _ []) ty) -> ty
+ other -> other
+ in
+ return (SigPatIn e t')
+
+ -- n+k patterns
+ OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _
+ (L _ (HsOverLit lit@(HsIntegral _ _)))
+ | plus == plus_RDR
+ -> return (mkNPlusKPat (L nloc n) lit)
+ where
+ plus_RDR = mkUnqual varName FSLIT("+") -- Hack
+
+ OpApp l op fix r -> checkLPat l >>= \l ->
+ checkLPat r >>= \r ->
+ case op of
+ L cl (HsVar c) | isDataOcc (rdrNameOcc c)
+ -> return (ConPatIn (L cl c) (InfixCon l r))
+ _ -> patFail loc
+
+ HsPar e -> checkLPat e >>= (return . ParPat)
+ ExplicitList _ es -> mapM (\e -> checkLPat e) es >>= \ps ->
+ return (ListPat ps placeHolderType)
+ ExplicitPArr _ es -> mapM (\e -> checkLPat e) es >>= \ps ->
+ return (PArrPat ps placeHolderType)
+
+ ExplicitTuple es b -> mapM (\e -> checkLPat e) es >>= \ps ->
+ return (TuplePat ps b)
+
+ RecordCon c _ fs -> mapM checkPatField fs >>= \fs ->
+ return (ConPatIn c (RecCon fs))