import Var ( Id )
import Type ( Type )
import DataCon ( DataCon, dataConWrapId, dataConSourceArity )
-import OccName ( mkVarOcc )
+import OccName ( mkVarOccFS )
import Name ( Name )
import BasicTypes ( RecFlag(..) )
import SrcLoc
mkHsDictApp expr [] = expr
mkHsDictApp expr dict_vars = L (getLoc expr) (DictApp expr dict_vars)
+mkHsCoerce :: ExprCoFn -> HsExpr id -> HsExpr id
+mkHsCoerce co_fn e | isIdCoercion co_fn = e
+ | otherwise = HsCoerce co_fn e
+
mkHsLam :: [LPat id] -> LHsExpr id -> LHsExpr id
mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches))
where
| isEmptyLHsBinds binds = expr
| otherwise = L (getLoc expr) (HsLet (HsValBinds val_binds) expr)
where
- val_binds = ValBindsOut [(Recursive, binds)]
+ val_binds = ValBindsOut [(Recursive, binds)] []
mkHsConApp :: DataCon -> [Type] -> [HsExpr Id] -> LHsExpr Id
-- Used for constructing dictinoary terms etc, so no locations
mkHsSplice e = HsSplice unqualSplice e
-unqualSplice = mkRdrUnqual (mkVarOcc FSLIT("splice"))
+unqualSplice = mkRdrUnqual (mkVarOccFS FSLIT("splice"))
-- A name (uniquified later) to
-- identify the splice
mkHsString s = HsString (mkFastString s)
+
+-------------
+userHsTyVarBndrs :: [Located name] -> [Located (HsTyVarBndr name)]
+userHsTyVarBndrs bndrs = [ L loc (UserTyVar v) | L loc v <- bndrs ]
\end{code}
nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con))
(PrefixCon (nOfThem (dataConSourceArity con) nlWildPat)))
-nlTuplePat pats box = noLoc (TuplePat pats box)
+nlTuplePat pats box = noLoc (TuplePat pats box placeHolderType)
nlWildPat = noLoc (WildPat placeHolderType) -- Pre-typechecking
nlHsDo :: HsStmtContext Name -> [LStmt id] -> LHsExpr id -> LHsExpr id
%************************************************************************
\begin{code}
-mkVarBind :: SrcSpan -> name -> LHsExpr name -> LHsBind name
-mkVarBind loc var rhs = mk_easy_FunBind loc var [] emptyLHsBinds rhs
+mkFunBind :: Located id -> [LMatch id] -> HsBind id
+-- Not infix, with place holders for coercion and free vars
+mkFunBind fn ms = FunBind { fun_id = fn, fun_infix = False, fun_matches = mkMatchGroup ms,
+ fun_co_fn = idCoercion, bind_fvs = placeHolderNames }
+
+
+mkVarBind :: SrcSpan -> RdrName -> LHsExpr RdrName -> LHsBind RdrName
+mkVarBind loc var rhs = mk_easy_FunBind loc var [] rhs
------------
-mk_easy_FunBind :: SrcSpan -> name -> [LPat name]
- -> LHsBinds name -> LHsExpr name
- -> LHsBind name
+mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat RdrName]
+ -> LHsExpr RdrName -> LHsBind RdrName
-mk_easy_FunBind loc fun pats binds expr
- = L loc (FunBind (L loc fun) False{-not infix-} matches placeHolderNames)
- where
- matches = mkMatchGroup [mk_easy_Match pats binds expr]
+mk_easy_FunBind loc fun pats expr
+ = L loc $ mkFunBind (L loc fun) [mkMatch pats expr emptyLocalBinds]
------------
mk_FunBind :: SrcSpan -> RdrName
mk_FunBind loc fun [] = panic "TcGenDeriv:mk_FunBind"
mk_FunBind loc fun pats_and_exprs
- = L loc (FunBind (L loc fun) False{-not infix-} matches placeHolderNames)
+ = L loc $ mkFunBind (L loc fun) matches
where
- matches = mkMatchGroup [mkMatch p e emptyLocalBinds | (p,e) <-pats_and_exprs]
-
-------------
-mk_easy_Match pats binds expr
- = mkMatch pats expr (HsValBinds (ValBindsIn binds []))
+ matches = [mkMatch p e emptyLocalBinds | (p,e) <-pats_and_exprs]
------------
mkMatch :: [LPat id] -> LHsExpr id -> HsLocalBinds id -> LMatch id
collectLocalBinders EmptyLocalBinds = []
collectHsValBinders :: HsValBinds name -> [Located name]
-collectHsValBinders (ValBindsIn binds sigs) = collectHsBindLocatedBinders binds
-collectHsValBinders (ValBindsOut binds) = panic "collectHsValBinders"
+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 (PatBind pat _ _ _) acc = collectLocatedPatBinders pat ++ acc
-collectAcc (FunBind f _ _ _) acc = f : acc
-collectAcc (VarBind f _) acc = noLoc f : acc
-collectAcc (AbsBinds _ _ dbinds binds) acc
+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
= [noLoc dp | (_,dp,_,_) <- dbinds] ++ acc
-- ++ foldr collectAcc acc binds
-- I don't think we want the binders from the nested binds
%************************************************************************
%* *
- Getting pattern signatures out of bindings
-%* *
-%************************************************************************
-
-Get all the pattern type signatures out of a bunch of bindings
-
-\begin{code}
-collectSigTysFromHsBinds :: [LHsBind name] -> [LHsType name]
-collectSigTysFromHsBinds binds = concat (map collectSigTysFromHsBind binds)
-
-collectSigTysFromHsBind :: LHsBind name -> [LHsType name]
-collectSigTysFromHsBind bind
- = go (unLoc bind)
- where
- go (PatBind pat _ _ _)
- = collectSigTysFromPat pat
- go (FunBind f _ (MatchGroup ms _) _)
- = [sig | L _ (Match [] (Just sig) _) <- ms]
- -- A binding like x :: a = f y
- -- is parsed as FunMonoBind, but for this purpose we
- -- want to treat it as a pattern binding
- go out_bind = panic "collectSigTysFromHsBind"
-\end{code}
-
-%************************************************************************
-%* *
Getting binders from statements
%* *
%************************************************************************
++ bndrs
go (WildPat _) = bndrs
go (LazyPat pat) = collectl pat bndrs
+ go (BangPat pat) = collectl pat bndrs
go (AsPat a pat) = a : 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 (TuplePat pats _ _) = foldr collectl bndrs pats
go (ConPatIn c ps) = foldr collectl bndrs (hsConArgs ps)
go (ConPatOut c _ ds bs ps _) = map noLoc ds
collect_lpat pat acc = collect_pat (unLoc pat) acc
-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 (AsPat a 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 (hsConArgs ps)
-collect_pat other acc = acc -- Literals, vars, wildcard
+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 (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 (hsConArgs ps)
+collect_pat other acc = acc -- Literals, vars, wildcard
\end{code}
projects / ghc-hetmet.git / blobdiff