X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FhsSyn%2FHsUtils.lhs;h=de883f25a5bd1d959c7eaf45bb11b6ba7d5cd7b6;hp=13f3cd7e55e0087738d0bdb09075503ef60955ef;hb=d76d9636aeebe933d160157331b8c8c0087e73ac;hpb=41dc5190d5ffec988834fa055f407157c1e1022b diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs index 13f3cd7..de883f2 100644 --- a/compiler/hsSyn/HsUtils.lhs +++ b/compiler/hsSyn/HsUtils.lhs @@ -21,7 +21,7 @@ module HsUtils( mkMatchGroup, mkMatch, mkHsLam, mkHsIf, mkHsWrap, mkLHsWrap, mkHsWrapCoI, mkLHsWrapCoI, coiToHsWrapper, mkHsLams, mkHsDictLet, - mkHsOpApp, mkHsDo, mkHsWrapPat, mkHsWrapPatCoI, + mkHsOpApp, mkHsDo, mkHsComp, mkHsWrapPat, mkHsWrapPatCoI, mkDoStmts, nlHsTyApp, nlHsVar, nlHsLit, nlHsApp, nlHsApps, nlHsIntLit, nlHsVarApps, nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList, @@ -42,8 +42,8 @@ module HsUtils( nlHsAppTy, nlHsTyVar, nlHsFunTy, nlHsTyConApp, -- Stmts - mkTransformStmt, mkTransformByStmt, mkExprStmt, mkBindStmt, - mkGroupUsingStmt, mkGroupByStmt, mkGroupByUsingStmt, + mkTransformStmt, mkTransformByStmt, mkExprStmt, mkBindStmt, mkLastStmt, + emptyGroupStmt, mkGroupUsingStmt, mkGroupByStmt, mkGroupByUsingStmt, emptyRecStmt, mkRecStmt, -- Template Haskell @@ -190,7 +190,9 @@ mkSimpleHsAlt pat expr mkHsIntegral :: Integer -> PostTcType -> HsOverLit id mkHsFractional :: Rational -> PostTcType -> HsOverLit id mkHsIsString :: FastString -> PostTcType -> HsOverLit id -mkHsDo :: HsStmtContext Name -> [LStmt id] -> LHsExpr id -> HsExpr id +mkHsDo :: HsStmtContext Name -> [LStmt id] -> HsExpr id +mkHsComp :: HsStmtContext Name -> [LStmt id] -> LHsExpr id -> HsExpr id +mkDoStmts :: [LStmt id] -> [LStmt id] mkNPat :: HsOverLit id -> Maybe (SyntaxExpr id) -> Pat id mkNPlusKPat :: Located id -> HsOverLit id -> Pat id @@ -198,6 +200,7 @@ mkNPlusKPat :: Located id -> HsOverLit id -> Pat id mkTransformStmt :: [LStmt idL] -> LHsExpr idR -> StmtLR idL idR mkTransformByStmt :: [LStmt idL] -> LHsExpr idR -> LHsExpr idR -> StmtLR idL idR +mkLastStmt :: LHsExpr idR -> StmtLR idL idR mkExprStmt :: LHsExpr idR -> StmtLR idL idR mkBindStmt :: LPat idL -> LHsExpr idR -> StmtLR idL idR @@ -212,7 +215,15 @@ mkHsIsString s = OverLit (HsIsString s) noRebindableInfo noSyntaxExpr noRebindableInfo :: Bool noRebindableInfo = error "noRebindableInfo" -- Just another placeholder; -mkHsDo ctxt stmts body = HsDo ctxt stmts body placeHolderType +-- mkDoStmts turns a trailing ExprStmt into a LastStmt +mkDoStmts [L loc (ExprStmt e _ _ _)] = [L loc (mkLastStmt e)] +mkDoStmts (s:ss) = s : mkDoStmts ss +mkDoStmts [] = [] + +mkHsDo ctxt stmts = HsDo ctxt stmts placeHolderType +mkHsComp ctxt stmts expr = mkHsDo ctxt (stmts ++ [last_stmt]) + where + last_stmt = L (getLoc expr) $ mkLastStmt expr mkHsIf :: LHsExpr id -> LHsExpr id -> LHsExpr id -> HsExpr id mkHsIf c a b = HsIf (Just noSyntaxExpr) c a b @@ -220,24 +231,31 @@ mkHsIf c a b = HsIf (Just noSyntaxExpr) c a b mkNPat lit neg = NPat lit neg noSyntaxExpr mkNPlusKPat id lit = NPlusKPat id lit noSyntaxExpr noSyntaxExpr -mkTransformStmt stmts usingExpr = TransformStmt stmts [] usingExpr Nothing -mkTransformByStmt stmts usingExpr byExpr = TransformStmt stmts [] usingExpr (Just byExpr) +mkTransformStmt stmts usingExpr = TransformStmt stmts [] usingExpr Nothing noSyntaxExpr noSyntaxExpr +mkTransformByStmt stmts usingExpr byExpr = TransformStmt stmts [] usingExpr (Just byExpr) noSyntaxExpr noSyntaxExpr mkGroupUsingStmt :: [LStmt idL] -> LHsExpr idR -> StmtLR idL idR mkGroupByStmt :: [LStmt idL] -> LHsExpr idR -> StmtLR idL idR mkGroupByUsingStmt :: [LStmt idL] -> LHsExpr idR -> LHsExpr idR -> StmtLR idL idR -mkGroupUsingStmt stmts usingExpr = GroupStmt stmts [] Nothing (Left usingExpr) -mkGroupByStmt stmts byExpr = GroupStmt stmts [] (Just byExpr) (Right noSyntaxExpr) -mkGroupByUsingStmt stmts byExpr usingExpr = GroupStmt stmts [] (Just byExpr) (Left usingExpr) - -mkExprStmt expr = ExprStmt expr noSyntaxExpr placeHolderType +emptyGroupStmt :: StmtLR idL idR +emptyGroupStmt = GroupStmt { grpS_stmts = [], grpS_bndrs = [], grpS_explicit = False + , grpS_by = Nothing, grpS_using = noLoc noSyntaxExpr + , grpS_ret = noSyntaxExpr, grpS_bind = noSyntaxExpr + , grpS_fmap = noSyntaxExpr } +mkGroupUsingStmt ss u = emptyGroupStmt { grpS_stmts = ss, grpS_explicit = True, grpS_using = u } +mkGroupByStmt ss b = emptyGroupStmt { grpS_stmts = ss, grpS_by = Just b } +mkGroupByUsingStmt ss b u = emptyGroupStmt { grpS_stmts = ss, grpS_by = Just b + , grpS_explicit = True, grpS_using = u } + +mkLastStmt expr = LastStmt expr noSyntaxExpr +mkExprStmt expr = ExprStmt expr noSyntaxExpr noSyntaxExpr placeHolderType mkBindStmt pat expr = BindStmt pat expr noSyntaxExpr noSyntaxExpr emptyRecStmt = RecStmt { recS_stmts = [], recS_later_ids = [], recS_rec_ids = [] , recS_ret_fn = noSyntaxExpr, recS_mfix_fn = noSyntaxExpr , recS_bind_fn = noSyntaxExpr - , recS_rec_rets = [] } + , recS_rec_rets = [], recS_ret_ty = placeHolderType } mkRecStmt stmts = emptyRecStmt { recS_stmts = stmts } @@ -327,8 +345,8 @@ nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con)) nlWildPat :: LPat id nlWildPat = noLoc (WildPat placeHolderType) -- Pre-typechecking -nlHsDo :: HsStmtContext Name -> [LStmt id] -> LHsExpr id -> LHsExpr id -nlHsDo ctxt stmts body = noLoc (mkHsDo ctxt stmts body) +nlHsDo :: HsStmtContext Name -> [LStmt id] -> LHsExpr id +nlHsDo ctxt stmts = noLoc (mkHsDo ctxt stmts) nlHsOpApp :: LHsExpr id -> id -> LHsExpr id -> LHsExpr id nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2) @@ -496,12 +514,13 @@ collectStmtBinders :: StmtLR idL idR -> [idL] -- Id Binders for a Stmt... [but what about pattern-sig type vars]? collectStmtBinders (BindStmt pat _ _ _) = collectPatBinders pat collectStmtBinders (LetStmt binds) = collectLocalBinders binds -collectStmtBinders (ExprStmt _ _ _) = [] -collectStmtBinders (ParStmt xs) = collectLStmtsBinders +collectStmtBinders (ExprStmt {}) = [] +collectStmtBinders (LastStmt {}) = [] +collectStmtBinders (ParStmt xs _ _ _) = collectLStmtsBinders $ concatMap fst xs -collectStmtBinders (TransformStmt stmts _ _ _) = collectLStmtsBinders stmts -collectStmtBinders (GroupStmt stmts _ _ _) = collectLStmtsBinders stmts -collectStmtBinders (RecStmt { recS_stmts = ss }) = collectLStmtsBinders ss +collectStmtBinders (TransformStmt stmts _ _ _ _ _) = collectLStmtsBinders stmts +collectStmtBinders (GroupStmt { grpS_stmts = stmts }) = collectLStmtsBinders stmts +collectStmtBinders (RecStmt { recS_stmts = ss }) = collectLStmtsBinders ss ----------------- Patterns -------------------------- @@ -642,12 +661,13 @@ lStmtsImplicits = hs_lstmts hs_stmt (BindStmt pat _ _ _) = lPatImplicits pat hs_stmt (LetStmt binds) = hs_local_binds binds - hs_stmt (ExprStmt _ _ _) = emptyNameSet - hs_stmt (ParStmt xs) = hs_lstmts $ concatMap fst xs + hs_stmt (ExprStmt {}) = emptyNameSet + hs_stmt (LastStmt {}) = emptyNameSet + hs_stmt (ParStmt xs _ _ _) = hs_lstmts $ concatMap fst xs - hs_stmt (TransformStmt stmts _ _ _) = hs_lstmts stmts - hs_stmt (GroupStmt stmts _ _ _) = hs_lstmts stmts - hs_stmt (RecStmt { recS_stmts = ss }) = hs_lstmts ss + hs_stmt (TransformStmt stmts _ _ _ _ _) = hs_lstmts stmts + hs_stmt (GroupStmt { grpS_stmts = stmts }) = hs_lstmts stmts + hs_stmt (RecStmt { recS_stmts = ss }) = hs_lstmts ss hs_local_binds (HsValBinds val_binds) = hsValBindsImplicits val_binds hs_local_binds (HsIPBinds _) = emptyNameSet