Id typecheck/TcHsSyn
\begin{code}
-{-# OPTIONS_GHC -w #-}
+{-# 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/WorkingConventions#Warnings
+-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
-- for details
module HsUtils where
import RdrName
import Var
+import Coercion
import Type
import DataCon
import Name
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))
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
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
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
-- 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}
%************************************************************************
\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}
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
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