X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FhsSyn%2FHsUtils.lhs;h=37a72050c52343b6224b2943acd54a7b8513e6ce;hp=3eaae63e641b64a0669cf9f4e8d8ec514b0a9716;hb=6f8ff0bbad3b9fa389c960ad1b5a267a1ae502f1;hpb=155cf24cf7fc7bf7c347aa9709b7ec0ef806224d diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs index 3eaae63..37a7205 100644 --- a/compiler/hsSyn/HsUtils.lhs +++ b/compiler/hsSyn/HsUtils.lhs @@ -1,3 +1,4 @@ + % % (c) The University of Glasgow, 1992-2006 % @@ -13,17 +14,8 @@ which deal with the intantiated versions are located elsewhere: Id typecheck/TcHsSyn \begin{code} -{-# OPTIONS -w #-} --- 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 --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details - module HsUtils where -#include "HsVersions.h" - import HsBinds import HsExpr import HsPat @@ -92,11 +84,11 @@ mkHsWrap co_fn e | isIdHsWrapper co_fn = e mkHsWrapCoI :: CoercionI -> HsExpr id -> HsExpr id mkHsWrapCoI IdCo e = e -mkHsWrapCoI (ACo co) e = mkHsWrap (WpCo co) e +mkHsWrapCoI (ACo co) e = mkHsWrap (WpCast co) e coiToHsWrapper :: CoercionI -> HsWrapper coiToHsWrapper IdCo = idHsWrapper -coiToHsWrapper (ACo co) = WpCo co +coiToHsWrapper (ACo co) = WpCast co mkHsLam :: [LPat id] -> LHsExpr id -> LHsExpr id mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches)) @@ -131,29 +123,80 @@ mkSimpleHsAlt pat expr -- These are the bits of syntax that contain rebindable names -- See RnEnv.lookupSyntaxName -mkHsIntegral i = HsIntegral i noSyntaxExpr -mkHsFractional f = HsFractional f noSyntaxExpr -mkHsIsString s = HsIsString s noSyntaxExpr +mkHsIntegral :: Integer -> PostTcType -> HsOverLit id +mkHsFractional :: Rational -> PostTcType -> HsOverLit id +mkHsIsString :: FastString -> PostTcType -> HsOverLit id +mkHsDo :: HsStmtContext Name -> [LStmt id] -> LHsExpr id -> HsExpr 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 + +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 + +mkExprStmt :: LHsExpr idR -> StmtLR idL idR +mkBindStmt :: LPat idL -> LHsExpr idR -> StmtLR idL idR + +emptyRecStmt :: StmtLR idL idR +mkRecStmt :: [LStmtLR idL idR] -> StmtLR idL idR + + +mkHsIntegral i = OverLit (HsIntegral i) noRebindableInfo noSyntaxExpr +mkHsFractional f = OverLit (HsFractional f) noRebindableInfo noSyntaxExpr +mkHsIsString s = OverLit (HsIsString s) noRebindableInfo noSyntaxExpr + +noRebindableInfo :: Bool +noRebindableInfo = error "noRebindableInfo" -- Just another placeholder; + mkHsDo ctxt stmts body = HsDo ctxt stmts body placeHolderType 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) + +mkGroupUsingStmt stmts usingExpr = GroupStmt (stmts, []) (GroupByNothing usingExpr) +mkGroupByStmt stmts byExpr = GroupStmt (stmts, []) (GroupBySomething (Right noSyntaxExpr) byExpr) +mkGroupByUsingStmt stmts byExpr usingExpr = GroupStmt (stmts, []) (GroupBySomething (Left usingExpr) byExpr) + mkExprStmt expr = ExprStmt expr noSyntaxExpr placeHolderType mkBindStmt pat expr = BindStmt pat expr noSyntaxExpr noSyntaxExpr -mkRecStmt stmts = RecStmt stmts [] [] [] emptyLHsBinds + +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_dicts = emptyLHsBinds } + +mkRecStmt stmts = emptyRecStmt { recS_stmts = stmts } ------------------------------- --- A useful function for building @OpApps@. The operator is always a -- variable, and we don't know the fixity yet. +mkHsOpApp :: LHsExpr id -> id -> LHsExpr id -> HsExpr id mkHsOpApp e1 op e2 = OpApp e1 (noLoc (HsVar op)) (error "mkOpApp:fixity") e2 +mkHsSplice :: LHsExpr RdrName -> HsSplice RdrName mkHsSplice e = HsSplice unqualSplice e -unqualSplice = mkRdrUnqual (mkVarOccFS FSLIT("splice")) +unqualSplice :: RdrName +unqualSplice = mkRdrUnqual (mkVarOccFS (fsLit "splice")) -- A name (uniquified later) to -- identify the splice +mkHsQuasiQuote :: RdrName -> SrcSpan -> FastString -> HsQuasiQuote RdrName +mkHsQuasiQuote quoter span quote = HsQuasiQuote quoter span quote + +unqualQuasiQuote :: RdrName +unqualQuasiQuote = mkRdrUnqual (mkVarOccFS (fsLit "quasiquote")) + -- A name (uniquified later) to + -- identify the quasi-quote + +mkHsString :: String -> HsLit mkHsString s = HsString (mkFastString s) ------------- @@ -184,6 +227,7 @@ nlLitPat l = noLoc (LitPat l) nlHsApp :: LHsExpr id -> LHsExpr id -> LHsExpr id nlHsApp f x = noLoc (HsApp f x) +nlHsIntLit :: Integer -> LHsExpr id nlHsIntLit n = noLoc (HsLit (HsInt n)) nlHsApps :: id -> [LHsExpr id] -> LHsExpr id @@ -210,29 +254,57 @@ nlWildConPat :: DataCon -> LPat RdrName nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con)) (PrefixCon (nOfThem (dataConSourceArity con) nlWildPat))) -nlTuplePat pats box = noLoc (TuplePat pats box placeHolderType) +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) +nlHsOpApp :: LHsExpr id -> id -> LHsExpr id -> LHsExpr id nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2) +nlHsLam :: LMatch id -> LHsExpr id +nlHsPar :: LHsExpr id -> LHsExpr id +nlHsIf :: LHsExpr id -> LHsExpr id -> LHsExpr id -> LHsExpr id +nlHsCase :: LHsExpr id -> [LMatch id] -> LHsExpr id +nlList :: [LHsExpr id] -> LHsExpr id + nlHsLam match = noLoc (HsLam (mkMatchGroup [match])) nlHsPar e = noLoc (HsPar e) nlHsIf cond true false = noLoc (HsIf cond true false) nlHsCase expr matches = noLoc (HsCase expr (mkMatchGroup matches)) -nlTuple exprs box = noLoc (ExplicitTuple exprs box) nlList exprs = noLoc (ExplicitList placeHolderType exprs) +nlHsAppTy :: LHsType name -> LHsType name -> LHsType name +nlHsTyVar :: name -> LHsType name +nlHsFunTy :: LHsType name -> LHsType name -> LHsType name + nlHsAppTy f t = noLoc (HsAppTy f t) nlHsTyVar x = noLoc (HsTyVar x) nlHsFunTy a b = noLoc (HsFunTy a b) +nlHsTyConApp :: name -> [LHsType name] -> LHsType name nlHsTyConApp tycon tys = foldl nlHsAppTy (nlHsTyVar tycon) tys \end{code} +Tuples. All these functions are *pre-typechecker* because they lack +types on the tuple. +\begin{code} +mkLHsTupleExpr :: [LHsExpr a] -> LHsExpr a +-- Makes a pre-typechecker boxed tuple, deals with 1 case +mkLHsTupleExpr [e] = e +mkLHsTupleExpr es = noLoc $ ExplicitTuple (map Present es) Boxed + +mkLHsVarTuple :: [a] -> LHsExpr a +mkLHsVarTuple ids = mkLHsTupleExpr (map nlHsVar ids) + +nlTuplePat :: [LPat id] -> Boxity -> LPat id +nlTuplePat pats box = noLoc (TuplePat pats box placeHolderType) + +missingTupArg :: HsTupArg a +missingTupArg = Missing placeHolderType +\end{code} %************************************************************************ %* * @@ -248,8 +320,12 @@ mkFunBind fn ms = FunBind { fun_id = fn, fun_infix = False, fun_matches = mkMatc fun_tick = Nothing } -mkVarBind :: SrcSpan -> id -> LHsExpr id -> LHsBind id -mkVarBind loc var rhs = mk_easy_FunBind loc var [] rhs +mkHsVarBind :: SrcSpan -> id -> LHsExpr id -> LHsBind id +mkHsVarBind loc var rhs = mk_easy_FunBind loc var [] rhs + +mkVarBind :: id -> LHsExpr id -> LHsBind id +mkVarBind var rhs = L (getLoc rhs) $ + VarBind { var_id = var, var_rhs = rhs, var_inline = False } ------------ mk_easy_FunBind :: SrcSpan -> id -> [LPat id] @@ -263,7 +339,7 @@ mk_FunBind :: SrcSpan -> id -> [([LPat id], LHsExpr id)] -> LHsBind id -mk_FunBind loc fun [] = panic "TcGenDeriv:mk_FunBind" +mk_FunBind _ _ [] = panic "TcGenDeriv:mk_FunBind" mk_FunBind loc fun pats_and_exprs = L loc $ mkFunBind (L loc fun) matches where @@ -275,9 +351,8 @@ mkMatch pats expr binds = noLoc (Match (map paren pats) Nothing (GRHSs (unguardedRHS expr) binds)) where - paren p = case p of - L _ (VarPat _) -> p - L l _ -> L l (ParPat p) + paren lp@(L l p) | hsPatNeedsParens p = L l (ParPat lp) + | otherwise = lp \end{code} @@ -304,8 +379,8 @@ collectLocalBinders (HsIPBinds _) = [] collectLocalBinders EmptyLocalBinds = [] collectHsValBinders :: HsValBindsLR idL idR -> [Located idL] -collectHsValBinders (ValBindsIn binds sigs) = collectHsBindLocatedBinders binds -collectHsValBinders (ValBindsOut binds sigs) = foldr collect_one [] binds +collectHsValBinders (ValBindsIn binds _) = collectHsBindLocatedBinders binds +collectHsValBinders (ValBindsOut binds _) = foldr collect_one [] binds where collect_one (_,binds) acc = foldrBag (collectAcc . unLoc) acc binds @@ -313,7 +388,7 @@ collectAcc :: HsBindLR idL idR -> [Located idL] -> [Located idL] collectAcc (PatBind { pat_lhs = p }) acc = collectLocatedPatBinders p ++ acc collectAcc (FunBind { fun_id = f }) acc = f : acc collectAcc (VarBind { var_id = f }) acc = noLoc f : acc -collectAcc (AbsBinds { abs_exports = dbinds, abs_binds = binds }) acc +collectAcc (AbsBinds { abs_exports = dbinds, abs_binds = _binds }) acc = [noLoc dp | (_,dp,_,_) <- dbinds] ++ acc -- ++ foldr collectAcc acc binds -- I don't think we want the binders from the nested binds @@ -351,7 +426,9 @@ collectStmtBinders (LetStmt binds) = collectLocalBinders binds collectStmtBinders (ExprStmt _ _ _) = [] collectStmtBinders (ParStmt xs) = collectLStmtsBinders $ concatMap fst xs -collectStmtBinders (RecStmt ss _ _ _ _) = collectLStmtsBinders ss +collectStmtBinders (TransformStmt (stmts, _) _ _) = collectLStmtsBinders stmts +collectStmtBinders (GroupStmt (stmts, _) _) = collectLStmtsBinders stmts +collectStmtBinders (RecStmt { recS_stmts = ss }) = collectLStmtsBinders ss \end{code} @@ -382,6 +459,7 @@ collectLocatedPatsBinders :: [LPat a] -> [Located a] collectLocatedPatsBinders pats = foldr collectl [] pats --------------------- +collectl :: LPat name -> [Located name] -> [Located name] collectl (L l pat) bndrs = go pat where @@ -392,14 +470,14 @@ collectl (L l pat) bndrs go (LazyPat pat) = collectl pat bndrs go (BangPat pat) = collectl pat bndrs go (AsPat a pat) = a : collectl pat bndrs - go (ViewPat exp pat _) = collectl pat bndrs + go (ViewPat _ pat _) = collectl pat bndrs go (ParPat pat) = collectl pat bndrs go (ListPat pats _) = foldr collectl bndrs pats go (PArrPat pats _) = foldr collectl bndrs pats go (TuplePat pats _ _) = foldr collectl bndrs pats - go (ConPatIn c ps) = foldr collectl bndrs (hsConPatArgs ps) + go (ConPatIn _ ps) = foldr collectl bndrs (hsConPatArgs ps) go (ConPatOut {pat_args=ps}) = foldr collectl bndrs (hsConPatArgs ps) -- See Note [Dictionary binders in ConPatOut] go (LitPat _) = bndrs @@ -408,8 +486,9 @@ collectl (L l pat) bndrs go (SigPatIn pat _) = collectl pat bndrs go (SigPatOut pat _) = collectl pat bndrs - go (TypePat ty) = bndrs - go (CoPat _ pat ty) = collectl (noLoc pat) bndrs + go (QuasiQuotePat _) = bndrs + go (TypePat _) = bndrs + go (CoPat _ pat _) = collectl (noLoc pat) bndrs \end{code} Note [Dictionary binders in ConPatOut] @@ -445,18 +524,20 @@ collectSigTysFromPats pats = foldr collect_lpat [] pats collectSigTysFromPat :: InPat name -> [LHsType name] collectSigTysFromPat pat = collect_lpat pat [] +collect_lpat :: InPat name -> [LHsType name] -> [LHsType name] collect_lpat pat acc = collect_pat (unLoc pat) acc +collect_pat :: Pat name -> [LHsType name] -> [LHsType name] collect_pat (SigPatIn pat ty) acc = collect_lpat pat (ty:acc) collect_pat (TypePat ty) acc = ty:acc collect_pat (LazyPat pat) acc = collect_lpat pat acc collect_pat (BangPat pat) acc = collect_lpat pat acc -collect_pat (AsPat a pat) acc = collect_lpat pat acc +collect_pat (AsPat _ pat) acc = collect_lpat pat acc collect_pat (ParPat pat) acc = collect_lpat pat acc collect_pat (ListPat pats _) acc = foldr collect_lpat acc pats collect_pat (PArrPat pats _) acc = foldr collect_lpat acc pats collect_pat (TuplePat pats _ _) acc = foldr collect_lpat acc pats -collect_pat (ConPatIn c ps) acc = foldr collect_lpat acc (hsConPatArgs ps) -collect_pat other acc = acc -- Literals, vars, wildcard +collect_pat (ConPatIn _ ps) acc = foldr collect_lpat acc (hsConPatArgs ps) +collect_pat _ acc = acc -- Literals, vars, wildcard \end{code}