X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FhsSyn%2FHsUtils.lhs;h=05352d07930d56562f30f41212cb73d4384f94d1;hb=c3a0d63e41d218108f2e2baa16f085399f1432f2;hp=0f75769ba360cbdb7651d9a79d2462414f34349b;hpb=bfe55fb767d566b5105c5584f698af1dd4a57346;p=ghc-hetmet.git

diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs
index 0f75769..05352d0 100644
--- a/compiler/hsSyn/HsUtils.lhs
+++ b/compiler/hsSyn/HsUtils.lhs
@@ -88,12 +88,16 @@ mkLHsWrap co_fn (L loc e) = L loc (mkHsWrap co_fn e)
 
 mkHsWrap :: HsWrapper -> HsExpr id -> HsExpr id
 mkHsWrap co_fn e | isIdHsWrapper co_fn = e
-		 | otherwise	      = HsWrap co_fn e
+		 | otherwise	       = HsWrap co_fn e
 
 mkHsWrapCoI :: CoercionI -> HsExpr id -> HsExpr id
 mkHsWrapCoI IdCo     e = e
 mkHsWrapCoI (ACo co) e = mkHsWrap (WpCo co) e
 
+coiToHsWrapper :: CoercionI -> HsWrapper
+coiToHsWrapper IdCo     = idHsWrapper
+coiToHsWrapper (ACo co) = WpCo co
+
 mkHsLam :: [LPat id] -> LHsExpr id -> LHsExpr id
 mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches))
 	where
@@ -132,9 +136,16 @@ mkHsFractional f       = HsFractional f  noSyntaxExpr
 mkHsIsString   s       = HsIsString   s  noSyntaxExpr
 mkHsDo ctxt stmts body = HsDo ctxt stmts body placeHolderType
 
-mkNPat lit neg     = NPat lit neg noSyntaxExpr 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
@@ -150,6 +161,12 @@ unqualSplice = mkRdrUnqual (mkVarOccFS FSLIT("splice"))
 		-- A name (uniquified later) to
 		-- identify the splice
 
+mkHsQuasiQuote quoter span quote = HsQuasiQuote unqualQuasiQuote quoter span quote
+
+unqualQuasiQuote = mkRdrUnqual (mkVarOccFS FSLIT("quasiquote"))
+		-- A name (uniquified later) to
+		-- identify the quasi-quote
+
 mkHsString s = HsString (mkFastString s)
 
 -------------
@@ -244,20 +261,20 @@ mkFunBind fn ms = FunBind { fun_id = fn, fun_infix = False, fun_matches = mkMatc
 			    fun_tick = Nothing }
 
 
-mkVarBind :: SrcSpan -> RdrName -> LHsExpr RdrName -> LHsBind RdrName
+mkVarBind :: SrcSpan -> id -> LHsExpr id -> LHsBind id
 mkVarBind loc var rhs = mk_easy_FunBind loc var [] rhs
 
 ------------
-mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat RdrName]
-		-> LHsExpr RdrName -> LHsBind RdrName
+mk_easy_FunBind :: SrcSpan -> id -> [LPat id]
+		-> LHsExpr id -> LHsBind id
 
 mk_easy_FunBind loc fun pats expr
   = L loc $ mkFunBind (L loc fun) [mkMatch pats expr emptyLocalBinds]
 
 ------------
-mk_FunBind :: SrcSpan -> RdrName
-	   -> [([LPat RdrName], LHsExpr RdrName)]
-	   -> LHsBind RdrName
+mk_FunBind :: SrcSpan -> id
+	   -> [([LPat id], LHsExpr id)]
+	   -> LHsBind id
 
 mk_FunBind loc fun [] = panic "TcGenDeriv:mk_FunBind"
 mk_FunBind loc fun pats_and_exprs
@@ -294,18 +311,18 @@ where
 it should return [x, y, f, a, b] (remember, order important).
 
 \begin{code}
-collectLocalBinders :: HsLocalBinds name -> [Located name]
+collectLocalBinders :: HsLocalBindsLR idL idR -> [Located idL]
 collectLocalBinders (HsValBinds val_binds) = collectHsValBinders val_binds
 collectLocalBinders (HsIPBinds _)   = []
 collectLocalBinders EmptyLocalBinds = []
 
-collectHsValBinders :: HsValBinds name -> [Located name]
+collectHsValBinders :: HsValBindsLR idL idR -> [Located idL]
 collectHsValBinders (ValBindsIn binds sigs)  = collectHsBindLocatedBinders binds
 collectHsValBinders (ValBindsOut binds sigs) = foldr collect_one [] binds
   where
    collect_one (_,binds) acc = foldrBag (collectAcc . unLoc) acc binds
 
-collectAcc :: HsBind name -> [Located name] -> [Located name]
+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
@@ -316,10 +333,10 @@ collectAcc (AbsBinds { abs_exports = dbinds, abs_binds = binds }) acc
 	-- The only time we collect binders from a typechecked 
 	-- binding (hence see AbsBinds) is in zonking in TcHsSyn
 
-collectHsBindBinders :: LHsBinds name -> [name]
+collectHsBindBinders :: LHsBindsLR idL idR -> [idL]
 collectHsBindBinders binds = map unLoc (collectHsBindLocatedBinders binds)
 
-collectHsBindLocatedBinders :: LHsBinds name -> [Located name]
+collectHsBindLocatedBinders :: LHsBindsLR idL idR -> [Located idL]
 collectHsBindLocatedBinders binds = foldrBag (collectAcc . unLoc) [] binds
 \end{code}
 
@@ -331,24 +348,25 @@ collectHsBindLocatedBinders binds = foldrBag (collectAcc . unLoc) [] binds
 %************************************************************************
 
 \begin{code}
-collectLStmtsBinders :: OutputableBndr id => [LStmt id] -> [Located id]
+collectLStmtsBinders :: [LStmtLR idL idR] -> [Located idL]
 collectLStmtsBinders = concatMap collectLStmtBinders
 
-collectStmtsBinders :: OutputableBndr id => [Stmt id] -> [Located id]
+collectStmtsBinders :: [StmtLR idL idR] -> [Located idL]
 collectStmtsBinders = concatMap collectStmtBinders
 
-collectLStmtBinders :: OutputableBndr id => LStmt id -> [Located id]
+collectLStmtBinders :: LStmtLR idL idR -> [Located idL]
 collectLStmtBinders = collectStmtBinders . unLoc
 
-collectStmtBinders :: OutputableBndr id => Stmt id -> [Located id]
+collectStmtBinders :: StmtLR idL idR -> [Located idL]
   -- Id Binders for a Stmt... [but what about pattern-sig type vars]?
 collectStmtBinders (BindStmt pat _ _ _) = collectLocatedPatBinders pat
 collectStmtBinders (LetStmt binds)      = collectLocalBinders binds
 collectStmtBinders (ExprStmt _ _ _)     = []
 collectStmtBinders (ParStmt xs)         = collectLStmtsBinders
                                         $ concatMap fst xs
+collectStmtBinders (TransformStmt (stmts, _) _ _) = collectLStmtsBinders stmts
+collectStmtBinders (GroupStmt (stmts, _) _)     = collectLStmtsBinders stmts
 collectStmtBinders (RecStmt ss _ _ _ _) = collectLStmtsBinders ss
-collectStmtBinders s                    = pprPanic "collectStmtBinders" (ppr s)
 \end{code}
 
 
@@ -389,6 +407,7 @@ 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 (ParPat  pat)     	  = collectl pat bndrs
 				  
     go (ListPat pats _)    	  = foldr collectl bndrs pats
@@ -399,11 +418,12 @@ collectl (L l pat) bndrs
     go (ConPatOut {pat_args=ps})  = foldr collectl bndrs (hsConPatArgs ps)
 	-- See Note [Dictionary binders in ConPatOut]
     go (LitPat _)	      	  = bndrs
-    go (NPat _ _ _ _)		  = bndrs
+    go (NPat _ _ _)		  = bndrs
     go (NPlusKPat n _ _ _)        = n : bndrs
  				  
     go (SigPatIn pat _)	 	  = collectl pat bndrs
     go (SigPatOut pat _)	  = collectl pat bndrs
+    go (QuasiQuotePat _)          = bndrs
     go (TypePat ty)               = bndrs
     go (CoPat _ pat ty)           = collectl (noLoc pat) bndrs
 \end{code}