X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FhsSyn%2FHsUtils.lhs;h=723e0f96f0d75e3e4a543613ce1bfbaa1589083b;hp=de883f25a5bd1d959c7eaf45bb11b6ba7d5cd7b6;hb=3391a03562d4056de7b16cd0f632e6c43ae44cca;hpb=d76d9636aeebe933d160157331b8c8c0087e73ac diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs index de883f2..723e0f9 100644 --- a/compiler/hsSyn/HsUtils.lhs +++ b/compiler/hsSyn/HsUtils.lhs @@ -19,9 +19,9 @@ module HsUtils( mkHsPar, mkHsApp, mkHsConApp, mkSimpleHsAlt, mkSimpleMatch, unguardedGRHSs, unguardedRHS, mkMatchGroup, mkMatch, mkHsLam, mkHsIf, - mkHsWrap, mkLHsWrap, mkHsWrapCoI, mkLHsWrapCoI, - coiToHsWrapper, mkHsLams, mkHsDictLet, - mkHsOpApp, mkHsDo, mkHsComp, mkHsWrapPat, mkHsWrapPatCoI, mkDoStmts, + mkHsWrap, mkLHsWrap, mkHsWrapCo, mkLHsWrapCo, + coToHsWrapper, mkHsDictLet, mkHsLams, + mkHsOpApp, mkHsDo, mkHsComp, mkHsWrapPat, mkHsWrapPatCo, nlHsTyApp, nlHsVar, nlHsLit, nlHsApp, nlHsApps, nlHsIntLit, nlHsVarApps, nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList, @@ -43,7 +43,7 @@ module HsUtils( -- Stmts mkTransformStmt, mkTransformByStmt, mkExprStmt, mkBindStmt, mkLastStmt, - emptyGroupStmt, mkGroupUsingStmt, mkGroupByStmt, mkGroupByUsingStmt, + emptyTransStmt, mkGroupUsingStmt, mkGroupByStmt, mkGroupByUsingStmt, emptyRecStmt, mkRecStmt, -- Template Haskell @@ -77,14 +77,13 @@ import HsLit import RdrName import Var import Coercion -import Type +import TypeRep import DataCon import Name import NameSet import BasicTypes import SrcLoc import FastString -import Outputable import Util import Bag @@ -137,25 +136,25 @@ mkHsWrap :: HsWrapper -> HsExpr id -> HsExpr id mkHsWrap co_fn e | isIdHsWrapper co_fn = e | otherwise = HsWrap co_fn e -mkHsWrapCoI :: CoercionI -> HsExpr id -> HsExpr id -mkHsWrapCoI (IdCo _) e = e -mkHsWrapCoI (ACo co) e = mkHsWrap (WpCast co) e +mkHsWrapCo :: Coercion -> HsExpr id -> HsExpr id +mkHsWrapCo (Refl _) e = e +mkHsWrapCo co e = mkHsWrap (WpCast co) e -mkLHsWrapCoI :: CoercionI -> LHsExpr id -> LHsExpr id -mkLHsWrapCoI (IdCo _) e = e -mkLHsWrapCoI (ACo co) (L loc e) = L loc (mkHsWrap (WpCast co) e) +mkLHsWrapCo :: Coercion -> LHsExpr id -> LHsExpr id +mkLHsWrapCo (Refl _) e = e +mkLHsWrapCo co (L loc e) = L loc (mkHsWrap (WpCast co) e) -coiToHsWrapper :: CoercionI -> HsWrapper -coiToHsWrapper (IdCo _) = idHsWrapper -coiToHsWrapper (ACo co) = WpCast co +coToHsWrapper :: Coercion -> HsWrapper +coToHsWrapper (Refl _) = idHsWrapper +coToHsWrapper co = WpCast co mkHsWrapPat :: HsWrapper -> Pat id -> Type -> Pat id mkHsWrapPat co_fn p ty | isIdHsWrapper co_fn = p | otherwise = CoPat co_fn p ty -mkHsWrapPatCoI :: CoercionI -> Pat id -> Type -> Pat id -mkHsWrapPatCoI (IdCo _) pat _ = pat -mkHsWrapPatCoI (ACo co) pat ty = CoPat (WpCast co) pat ty +mkHsWrapPatCo :: Coercion -> Pat id -> Type -> Pat id +mkHsWrapPatCo (Refl _) pat _ = pat +mkHsWrapPatCo co pat ty = CoPat (WpCast co) pat ty mkHsLam :: [LPat id] -> LHsExpr id -> LHsExpr id mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches)) @@ -188,18 +187,14 @@ mkSimpleHsAlt pat expr -- See RnEnv.lookupSyntaxName mkHsIntegral :: Integer -> PostTcType -> HsOverLit id -mkHsFractional :: Rational -> PostTcType -> HsOverLit id +mkHsFractional :: FractionalLit -> PostTcType -> HsOverLit id mkHsIsString :: FastString -> PostTcType -> HsOverLit 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 -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 @@ -215,11 +210,6 @@ mkHsIsString s = OverLit (HsIsString s) noRebindableInfo noSyntaxExpr noRebindableInfo :: Bool noRebindableInfo = error "noRebindableInfo" -- Just another placeholder; --- 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 @@ -231,22 +221,23 @@ 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 noSyntaxExpr noSyntaxExpr -mkTransformByStmt stmts usingExpr byExpr = TransformStmt stmts [] usingExpr (Just byExpr) noSyntaxExpr noSyntaxExpr - +mkTransformStmt :: [LStmt idL] -> LHsExpr idR -> StmtLR idL idR +mkTransformByStmt :: [LStmt idL] -> LHsExpr idR -> LHsExpr idR -> StmtLR idL idR 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 -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 } +emptyTransStmt :: StmtLR idL idR +emptyTransStmt = TransStmt { trS_form = undefined, trS_stmts = [], trS_bndrs = [] + , trS_by = Nothing, trS_using = noLoc noSyntaxExpr + , trS_ret = noSyntaxExpr, trS_bind = noSyntaxExpr + , trS_fmap = noSyntaxExpr } +mkTransformStmt ss u = emptyTransStmt { trS_form = ThenForm, trS_stmts = ss, trS_using = u } +mkTransformByStmt ss u b = emptyTransStmt { trS_form = ThenForm, trS_stmts = ss, trS_using = u, trS_by = Just b } +mkGroupByStmt ss b = emptyTransStmt { trS_form = GroupFormB, trS_stmts = ss, trS_by = Just b } +mkGroupUsingStmt ss u = emptyTransStmt { trS_form = GroupFormU, trS_stmts = ss, trS_using = u } +mkGroupByUsingStmt ss b u = emptyTransStmt { trS_form = GroupFormU, trS_stmts = ss + , trS_by = Just b, trS_using = u } mkLastStmt expr = LastStmt expr noSyntaxExpr mkExprStmt expr = ExprStmt expr noSyntaxExpr noSyntaxExpr placeHolderType @@ -518,9 +509,8 @@ collectStmtBinders (ExprStmt {}) = [] collectStmtBinders (LastStmt {}) = [] collectStmtBinders (ParStmt xs _ _ _) = collectLStmtsBinders $ concatMap fst xs -collectStmtBinders (TransformStmt stmts _ _ _ _ _) = collectLStmtsBinders stmts -collectStmtBinders (GroupStmt { grpS_stmts = stmts }) = collectLStmtsBinders stmts -collectStmtBinders (RecStmt { recS_stmts = ss }) = collectLStmtsBinders ss +collectStmtBinders (TransStmt { trS_stmts = stmts }) = collectLStmtsBinders stmts +collectStmtBinders (RecStmt { recS_stmts = ss }) = collectLStmtsBinders ss ----------------- Patterns -------------------------- @@ -665,9 +655,8 @@ lStmtsImplicits = hs_lstmts hs_stmt (LastStmt {}) = emptyNameSet hs_stmt (ParStmt xs _ _ _) = hs_lstmts $ concatMap fst xs - 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_stmt (TransStmt { trS_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 @@ -675,11 +664,15 @@ lStmtsImplicits = hs_lstmts hsValBindsImplicits :: HsValBindsLR Name idR -> NameSet hsValBindsImplicits (ValBindsOut binds _) - = unionManyNameSets [foldBag unionNameSets (hs_bind . unLoc) emptyNameSet hs_binds | (_rec, hs_binds) <- binds] + = foldr (unionNameSets . lhsBindsImplicits . snd) emptyNameSet binds +hsValBindsImplicits (ValBindsIn binds _) + = lhsBindsImplicits binds + +lhsBindsImplicits :: LHsBindsLR Name idR -> NameSet +lhsBindsImplicits = foldBag unionNameSets lhs_bind emptyNameSet where - hs_bind (PatBind { pat_lhs = lpat }) = lPatImplicits lpat - hs_bind _ = emptyNameSet -hsValBindsImplicits (ValBindsIn {}) = pprPanic "hsValBindsImplicits: ValBindsIn" empty + lhs_bind (L _ (PatBind { pat_lhs = lpat })) = lPatImplicits lpat + lhs_bind _ = emptyNameSet lPatImplicits :: LPat Name -> NameSet lPatImplicits = hs_lpat