From 43a0864f6edd5d2b626dbeb592d1449b066ca90d Mon Sep 17 00:00:00 2001 From: Twan van Laarhoven Date: Mon, 4 Feb 2008 01:50:53 +0000 Subject: [PATCH] Monadification and Fixed warnings in parser/RdrHsSyn, except for incomplete pattern matches --- compiler/parser/RdrHsSyn.lhs | 230 ++++++++++++++++++++++++------------------ 1 file changed, 134 insertions(+), 96 deletions(-) diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index be51624..2fb494e 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -4,7 +4,7 @@ Functions over HsSyn specialised to RdrName. \begin{code} -{-# OPTIONS -w #-} +{-# OPTIONS -fno-warn-incomplete-patterns #-} -- The above warning supression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and fix -- any warnings in the module. See @@ -61,6 +61,8 @@ module RdrHsSyn ( #include "HsVersions.h" import HsSyn -- Lots of it +import Class ( FunDep ) +import TypeRep ( Kind ) import RdrName ( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc, isRdrDataCon, isUnqual, getRdrName, isQual, setRdrNameSpace ) @@ -101,12 +103,15 @@ extractHsRhoRdrTyVars :: LHsContext RdrName -> LHsType RdrName -> [Located RdrNa extractHsRhoRdrTyVars ctxt ty = nubBy eqLocated $ extract_lctxt ctxt (extract_lty ty []) +extract_lctxt :: Located [LHsPred RdrName] -> [Located RdrName] -> [Located RdrName] extract_lctxt ctxt acc = foldr (extract_pred . unLoc) acc (unLoc ctxt) -extract_pred (HsClassP cls tys) acc = foldr extract_lty acc tys +extract_pred :: HsPred RdrName -> [Located RdrName] -> [Located RdrName] +extract_pred (HsClassP _ tys) acc = foldr extract_lty acc tys extract_pred (HsEqualP ty1 ty2) acc = extract_lty ty1 (extract_lty ty2 acc) -extract_pred (HsIParam n ty ) acc = extract_lty ty acc +extract_pred (HsIParam _ ty ) acc = extract_lty ty acc +extract_lty :: LHsType RdrName -> [Located RdrName] -> [Located RdrName] extract_lty (L loc ty) acc = case ty of HsTyVar tv -> extract_tv loc tv acc @@ -119,15 +124,15 @@ extract_lty (L loc ty) acc HsPredTy p -> extract_pred p acc HsOpTy ty1 (L loc tv) ty2 -> extract_tv loc tv (extract_lty ty1 (extract_lty ty2 acc)) HsParTy ty -> extract_lty ty acc - HsNumTy num -> acc + HsNumTy _ -> acc HsSpliceTy _ -> acc -- Type splices mention no type variables - HsKindSig ty k -> extract_lty ty acc - HsForAllTy exp [] cx ty -> extract_lctxt cx (extract_lty ty acc) - HsForAllTy exp tvs cx ty -> acc ++ (filter ((`notElem` locals) . unLoc) $ + HsKindSig ty _ -> extract_lty ty acc + HsForAllTy _ [] cx ty -> extract_lctxt cx (extract_lty ty acc) + HsForAllTy _ tvs cx ty -> acc ++ (filter ((`notElem` locals) . unLoc) $ extract_lctxt cx (extract_lty ty [])) where locals = hsLTyVarNames tvs - HsDocTy ty doc -> extract_lty ty acc + HsDocTy ty _ -> extract_lty ty acc extract_tv :: SrcSpan -> RdrName -> [Located RdrName] -> [Located RdrName] extract_tv loc tv acc | isRdrTyVar tv = L loc tv : acc @@ -140,10 +145,10 @@ extractGenericPatTyVars binds = nubBy eqLocated (foldrBag get [] binds) where get (L _ (FunBind { fun_matches = MatchGroup ms _ })) acc = foldr (get_m.unLoc) acc ms - get other acc = acc + get _ acc = acc get_m (Match (L _ (TypePat ty) : _) _ _) acc = extract_lty ty acc - get_m other acc = acc + get_m _ acc = acc \end{code} @@ -164,6 +169,13 @@ Similarly for mkConDecl, mkClassOpSig and default-method names. *** See "THE NAMING STORY" in HsDecls **** \begin{code} +mkClassDecl :: (LHsContext name, Located name, [LHsTyVarBndr name]) + -> [Located (FunDep name)] + -> [LSig name] + -> LHsBinds name + -> [LTyClDecl name] + -> [LDocDecl name] + -> TyClDecl name mkClassDecl (cxt, cname, tyvars) fds sigs mbinds ats docs = ClassDecl { tcdCtxt = cxt, tcdLName = cname, tcdTyVars = tyvars, tcdFDs = fds, @@ -173,6 +185,15 @@ mkClassDecl (cxt, cname, tyvars) fds sigs mbinds ats docs tcdDocs = docs } +mkTyData :: NewOrData + -> (LHsContext name, + Located name, + [LHsTyVarBndr name], + Maybe [LHsType name]) + -> Maybe Kind + -> [LConDecl name] + -> Maybe [LHsType name] + -> TyClDecl name mkTyData new_or_data (context, tname, tyvars, typats) ksig data_cons maybe_deriv = TyData { tcdND = new_or_data, tcdCtxt = context, tcdLName = tname, tcdTyVars = tyvars, tcdTyPats = typats, tcdCons = data_cons, @@ -216,9 +237,9 @@ cvBindsAndSigs :: OrdList (LHsDecl RdrName) cvBindsAndSigs fb = go (fromOL fb) where go [] = (emptyBag, [], [], []) - go (L l x@(SigD s) : ds) = (bs, L l s : ss, ts, docs) + go (L l (SigD s) : ds) = (bs, L l s : ss, ts, docs) where (bs, ss, ts, docs) = go ds - go (L l x@(ValD b) : ds) = (b' `consBag` bs, ss, ts, docs) + go (L l (ValD b) : ds) = (b' `consBag` bs, ss, ts, docs) where (b', ds') = getMonoBind (L l b) ds (bs, ss, ts, docs) = go ds' go (L l (TyClD t): ds) = (bs, ss, L l t : ts, docs) @@ -244,8 +265,8 @@ getMonoBind :: LHsBind RdrName -> [LHsDecl RdrName] -- -- No AndMonoBinds or EmptyMonoBinds here; just single equations -getMonoBind (L loc1 bind@(FunBind { fun_id = fun_id1@(L _ f1), fun_infix = is_infix1, - fun_matches = MatchGroup mtchs1 _ })) binds +getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1), fun_infix = is_infix1, + fun_matches = MatchGroup mtchs1 _ })) binds | has_args mtchs1 = go is_infix1 mtchs1 loc1 binds [] where @@ -264,6 +285,7 @@ getMonoBind (L loc1 bind@(FunBind { fun_id = fun_id1@(L _ f1), fun_infix = is_in getMonoBind bind binds = (bind, binds) +has_args :: [LMatch RdrName] -> Bool has_args ((L _ (Match args _ _)) : _) = not (null args) -- Don't group together FunBinds if they have -- no arguments. This is necessary now that variable bindings @@ -296,7 +318,7 @@ addl gp (L l d : ds) = add gp l d ds add :: HsGroup a -> SrcSpan -> HsDecl a -> [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a])) -add gp l (SpliceD e) ds = (gp, Just (e, ds)) +add gp _ (SpliceD e) ds = (gp, Just (e, ds)) -- Class declarations: pull out the fixity signatures to the top add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) @@ -334,7 +356,10 @@ add gp@(HsGroup {hs_ruleds = ts}) l (RuleD d) ds add gp l (DocD d) ds = addl (gp { hs_docs = (L l d) : (hs_docs gp) }) ds +add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs + +add_sig :: LSig a -> HsValBinds a -> HsValBinds a add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs) \end{code} @@ -412,11 +437,11 @@ checkTyVars :: [LHsType RdrName] -> P () checkTyVars tparms = mapM_ chk tparms where -- Check that the name space is correct! - chk (L l (HsKindSig (L _ (HsTyVar tv)) k)) + chk (L _ (HsKindSig (L _ (HsTyVar tv)) _)) | isRdrTyVar tv = return () - chk (L l (HsTyVar tv)) + chk (L _ (HsTyVar tv)) | isRdrTyVar tv = return () - chk (L l other) = + chk (L l _) = parseError l "Type found where type variable expected" -- Check whether the type arguments in a type synonym head are simply @@ -465,20 +490,20 @@ checkTyClHdr (L l cxt) ty go l (HsTyVar tc) acc | isRdrTc tc = do tvs <- extractTyVars acc return (L l tc, tvs, acc) - go l (HsOpTy t1 ltc@(L _ tc) t2) acc + go _ (HsOpTy t1 ltc@(L _ tc) t2) acc | isRdrTc tc = do tvs <- extractTyVars (t1:t2:acc) return (ltc, tvs, t1:t2:acc) - go l (HsParTy ty) acc = gol ty acc - go l (HsAppTy t1 t2) acc = gol t1 (t2:acc) - go l other acc = + go _ (HsParTy ty) acc = gol ty acc + go _ (HsAppTy t1 t2) acc = gol t1 (t2:acc) + go l _ _ = parseError l "Malformed head of type or class declaration" -- The predicates in a type or class decl must be class predicates or -- equational constraints. They need not all have variable-only -- arguments, even in Haskell 98. -- E.g. class (Monad m, Monad (t m)) => MonadT t m - chk_pred (L l (HsClassP _ _)) = return () - chk_pred (L l (HsEqualP _ _)) = return () + chk_pred (L _ (HsClassP _ _)) = return () + chk_pred (L _ (HsEqualP _ _)) = return () chk_pred (L l _) = parseError l "Malformed context in type or class declaration" @@ -488,45 +513,39 @@ checkTyClHdr (L l cxt) ty -- declarations). -- extractTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName] -extractTyVars tvs = collects [] tvs +extractTyVars tvs = collects tvs [] where -- Collect all variables (1st arg serves as an accumulator) - collect tvs (L l (HsForAllTy _ _ _ _)) = - parseError l "Forall type not allowed as type parameter" - collect tvs (L l (HsTyVar tv)) - | isRdrTyVar tv = return $ L l (UserTyVar tv) : tvs - | otherwise = return tvs - collect tvs (L l (HsBangTy _ _ )) = - parseError l "Bang-style type annotations not allowed as type parameter" - collect tvs (L l (HsAppTy t1 t2 )) = do - tvs' <- collect tvs t2 - collect tvs' t1 - collect tvs (L l (HsFunTy t1 t2 )) = do - tvs' <- collect tvs t2 - collect tvs' t1 - collect tvs (L l (HsListTy t )) = collect tvs t - collect tvs (L l (HsPArrTy t )) = collect tvs t - collect tvs (L l (HsTupleTy _ ts )) = collects tvs ts - collect tvs (L l (HsOpTy t1 _ t2 )) = do - tvs' <- collect tvs t2 - collect tvs' t1 - collect tvs (L l (HsParTy t )) = collect tvs t - collect tvs (L l (HsNumTy t )) = return tvs - collect tvs (L l (HsPredTy t )) = - parseError l "Predicate not allowed as type parameter" - collect tvs (L l (HsKindSig (L _ (HsTyVar tv)) k)) - | isRdrTyVar tv = - return $ L l (KindedTyVar tv k) : tvs - | otherwise = - parseError l "Kind signature only allowed for type variables" - collect tvs (L l (HsSpliceTy t )) = - parseError l "Splice not allowed as type parameter" + collect (L l (HsForAllTy _ _ _ _)) = + const $ parseError l "Forall type not allowed as type parameter" + collect (L l (HsTyVar tv)) + | isRdrTyVar tv = return . (L l (UserTyVar tv) :) + | otherwise = return + collect (L l (HsBangTy _ _ )) = + const $ parseError l "Bang-style type annotations not allowed as type parameter" + collect (L _ (HsAppTy t1 t2 )) = collect t2 >=> collect t1 + collect (L _ (HsFunTy t1 t2 )) = collect t2 >=> collect t1 + collect (L _ (HsListTy t )) = collect t + collect (L _ (HsPArrTy t )) = collect t + collect (L _ (HsTupleTy _ ts )) = collects ts + collect (L _ (HsOpTy t1 _ t2 )) = collect t2 >=> collect t1 + collect (L _ (HsParTy t )) = collect t + collect (L _ (HsNumTy _ )) = return + collect (L l (HsPredTy _ )) = + const $ parseError l "Predicate not allowed as type parameter" + collect (L l (HsKindSig (L _ (HsTyVar tv)) k)) + | isRdrTyVar tv = + return . (L l (KindedTyVar tv k) :) + | otherwise = + const $ parseError l "Kind signature only allowed for type variables" + collect (L l (HsSpliceTy _ )) = + const $ parseError l "Splice not allowed as type parameter" -- Collect all variables of a list of types - collects tvs [] = return tvs - collects tvs (t:ts) = do - tvs' <- collects tvs ts - collect tvs' t + collects [] = return + collects (t:ts) = collects ts >=> collect t + + (f >=> g) x = f x >>= g -- Check that associated type declarations of a class are all kind signatures. -- @@ -597,15 +616,17 @@ checkDerivDecl d@(L loc _) = -- (b) returns it separately -- same comments apply for mdo as well +checkDo, checkMDo :: SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName) + checkDo = checkDoMDo "a " "'do'" checkMDo = checkDoMDo "an " "'mdo'" checkDoMDo :: String -> String -> SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName) -checkDoMDo pre nm loc [] = parseError loc ("Empty " ++ nm ++ " construct") -checkDoMDo pre nm loc ss = do +checkDoMDo _ nm loc [] = parseError loc ("Empty " ++ nm ++ " construct") +checkDoMDo pre nm _ ss = do check ss where - check [L l (ExprStmt e _ _)] = return ([], e) + check [L _ (ExprStmt e _ _)] = return ([], e) check [L l _] = parseError l ("The last statement in " ++ pre ++ nm ++ " construct must be an expression") check (s:ss) = do @@ -640,9 +661,10 @@ 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 +checkPat loc _ _ = patFail loc +checkAPat :: SrcSpan -> HsExpr RdrName -> P (Pat RdrName) checkAPat loc e = case e of EWildPat -> return (WildPat placeHolderType) HsVar x | isQual x -> parseError loc ("Qualified variable in pattern: " @@ -667,15 +689,14 @@ checkAPat loc e = case e of EAsPat n e -> checkLPat e >>= (return . AsPat n) -- view pattern is well-formed if the pattern is EViewPat expr patE -> checkLPat patE >>= (return . (\p -> ViewPat expr p placeHolderType)) - 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') + ExprWithTySig e t -> do e <- checkLPat 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 + return (SigPatIn e t') -- n+k patterns OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _ @@ -683,25 +704,25 @@ checkAPat loc e = case e of | plus == plus_RDR -> return (mkNPlusKPat (L nloc n) lit) - 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 + OpApp l op _fix r -> do l <- checkLPat l + r <- checkLPat 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) + HsPar e -> checkLPat e >>= (return . ParPat) + ExplicitList _ es -> do ps <- mapM (\e -> checkLPat e) es + return (ListPat ps placeHolderType) + ExplicitPArr _ es -> do ps <- mapM (\e -> checkLPat e) es + return (PArrPat ps placeHolderType) - ExplicitTuple es b -> mapM (\e -> checkLPat e) es >>= \ps -> - return (TuplePat ps b placeHolderType) + ExplicitTuple es b -> do ps <- mapM (\e -> checkLPat e) es + return (TuplePat ps b placeHolderType) - RecordCon c _ (HsRecFields fs dd) - -> mapM checkPatField fs >>= \fs -> - return (ConPatIn c (RecCon (HsRecFields fs dd))) + RecordCon c _ (HsRecFields fs dd) + -> do fs <- mapM checkPatField fs + return (ConPatIn c (RecCon (HsRecFields fs dd))) HsQuasiQuoteE q -> return (QuasiQuotePat q) -- Generics HsType ty -> return (TypePat ty) @@ -715,6 +736,7 @@ checkPatField :: HsRecField RdrName (LHsExpr RdrName) -> P (HsRecField RdrName ( checkPatField fld = do { p <- checkLPat (hsRecFieldArg fld) ; return (fld { hsRecFieldArg = p }) } +patFail :: SrcSpan -> P a patFail loc = parseError loc "Parse error in pattern" @@ -737,6 +759,13 @@ checkValDef lhs opt_sig grhss fun is_infix pats opt_sig grhss Nothing -> checkPatBind lhs grhss } +checkFunBind :: SrcSpan + -> Located RdrName + -> Bool + -> [LHsExpr RdrName] + -> Maybe (LHsType RdrName) + -> Located (GRHSs RdrName) + -> P (HsBind RdrName) checkFunBind lhs_loc fun is_infix pats opt_sig (L rhs_span grhss) | isQual (unLoc fun) = parseError (getLoc fun) ("Qualified name in function definition: " ++ @@ -754,6 +783,9 @@ makeFunBind fn is_infix ms = FunBind { fun_id = fn, fun_infix = is_infix, fun_matches = mkMatchGroup ms, fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames, fun_tick = Nothing } +checkPatBind :: LHsExpr RdrName + -> Located (GRHSs RdrName) + -> P (HsBind RdrName) checkPatBind lhs (L _ grhss) = do { lhs <- checkPattern lhs ; return (PatBind lhs grhss placeHolderType placeHolderNames) } @@ -765,7 +797,7 @@ checkValSig checkValSig (L l (HsVar v)) ty | isUnqual v && not (isDataOcc (rdrNameOcc v)) = return (TypeSig (L l v) ty) -checkValSig (L l other) ty +checkValSig (L l _) _ = parseError l "Invalid type signature" mkGadtDecl :: Located RdrName @@ -774,6 +806,11 @@ mkGadtDecl :: Located RdrName mkGadtDecl name (L _ (HsForAllTy _ qvars cxt ty)) = mk_gadt_con name qvars cxt ty mkGadtDecl name ty = mk_gadt_con name [] (noLoc []) ty +mk_gadt_con :: Located RdrName + -> [LHsTyVarBndr RdrName] + -> LHsContext RdrName + -> LHsType RdrName + -> ConDecl RdrName mk_gadt_con name qvars cxt ty = ConDecl { con_name = name , con_explicit = Implicit @@ -793,13 +830,13 @@ mk_gadt_con name qvars cxt ty -- not be any OpApps inside the e's splitBang :: LHsExpr RdrName -> Maybe (LHsExpr RdrName, [LHsExpr RdrName]) -- Splits (f ! g a b) into (f, [(! g), a, b]) -splitBang (L loc (OpApp l_arg bang@(L loc' (HsVar op)) _ r_arg)) +splitBang (L loc (OpApp l_arg bang@(L _ (HsVar op)) _ r_arg)) | op == bang_RDR = Just (l_arg, L loc (SectionR bang arg1) : argns) where (arg1,argns) = split_bang r_arg [] split_bang (L _ (HsApp f e)) es = split_bang f (e:es) split_bang e es = (e,es) -splitBang other = Nothing +splitBang _ = Nothing isFunLhs :: LHsExpr RdrName -> P (Maybe (Located RdrName, Bool, [LHsExpr RdrName])) @@ -866,12 +903,13 @@ mkRecConstrOrUpdate -> ([HsRecField RdrName (LHsExpr RdrName)], Bool) -> P (HsExpr RdrName) -mkRecConstrOrUpdate (L l (HsVar c)) loc (fs,dd) | isRdrDataCon c +mkRecConstrOrUpdate (L l (HsVar c)) _ (fs,dd) | isRdrDataCon c = return (RecordCon (L l c) noPostTcExpr (mk_rec_fields fs dd)) mkRecConstrOrUpdate exp loc (fs,dd) | null fs = parseError loc "Empty record update" | otherwise = return (RecordUpd exp (mk_rec_fields fs dd) [] [] []) +mk_rec_fields :: [HsRecField id arg] -> Bool -> HsRecFields id arg mk_rec_fields fs False = HsRecFields { rec_flds = fs, rec_dotdot = Nothing } mk_rec_fields fs True = HsRecFields { rec_flds = fs, rec_dotdot = Just (length fs) } @@ -983,8 +1021,8 @@ parseDImport (L loc entity) = parse0 comps parse2 _ _ [] = d'oh parse2 isStatic kind (('[':x):xs) = case x of - [] -> d'oh - vs | last vs == ']' -> parse3 isStatic kind (init vs) xs + vs | last vs == ']' -> parse3 isStatic kind (init vs) xs + _ -> d'oh parse2 isStatic kind xs = parse3 isStatic kind "" xs parse3 isStatic kind assem [x] = @@ -1001,12 +1039,12 @@ parseDImport (L loc entity) = parse0 comps mkExport :: CallConv -> (Located FastString, Located RdrName, LHsType RdrName) -> P (HsDecl RdrName) -mkExport (CCall cconv) (L loc entity, v, ty) = return $ +mkExport (CCall cconv) (L _ entity, v, ty) = return $ ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv))) where entity' | nullFS entity = mkExtName (unLoc v) | otherwise = entity -mkExport DNCall (L loc entity, v, ty) = +mkExport DNCall (L _ _, v, _) = parseError (getLoc v){-TODO: not quite right-} "Foreign export is not yet supported for .NET" -- 1.7.10.4