diff options
Diffstat (limited to 'compiler/hsSyn')
| -rw-r--r-- | compiler/hsSyn/Convert.lhs | 622 | ||||
| -rw-r--r-- | compiler/hsSyn/HsBinds.lhs | 479 | ||||
| -rw-r--r-- | compiler/hsSyn/HsDecls.lhs | 796 | ||||
| -rw-r--r-- | compiler/hsSyn/HsExpr.hi-boot-5 | 14 | ||||
| -rw-r--r-- | compiler/hsSyn/HsExpr.hi-boot-6 | 22 | ||||
| -rw-r--r-- | compiler/hsSyn/HsExpr.lhs | 975 | ||||
| -rw-r--r-- | compiler/hsSyn/HsExpr.lhs-boot | 27 | ||||
| -rw-r--r-- | compiler/hsSyn/HsImpExp.lhs | 125 | ||||
| -rw-r--r-- | compiler/hsSyn/HsLit.lhs | 96 | ||||
| -rw-r--r-- | compiler/hsSyn/HsPat.hi-boot-5 | 6 | ||||
| -rw-r--r-- | compiler/hsSyn/HsPat.hi-boot-6 | 4 | ||||
| -rw-r--r-- | compiler/hsSyn/HsPat.lhs | 324 | ||||
| -rw-r--r-- | compiler/hsSyn/HsPat.lhs-boot | 7 | ||||
| -rw-r--r-- | compiler/hsSyn/HsSyn.lhs | 98 | ||||
| -rw-r--r-- | compiler/hsSyn/HsTypes.lhs | 370 | ||||
| -rw-r--r-- | compiler/hsSyn/HsUtils.lhs | 423 |
16 files changed, 4388 insertions, 0 deletions
diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs new file mode 100644 index 0000000000..6c14c11893 --- /dev/null +++ b/compiler/hsSyn/Convert.lhs @@ -0,0 +1,622 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +% + +This module converts Template Haskell syntax into HsSyn + + +\begin{code} +module Convert( convertToHsExpr, convertToHsDecls, convertToHsType, thRdrName ) where + +#include "HsVersions.h" + +import Language.Haskell.TH as TH hiding (sigP) +import Language.Haskell.TH.Syntax as TH + +import HsSyn as Hs +import qualified Class (FunDep) +import RdrName ( RdrName, mkRdrUnqual, mkRdrQual, mkOrig, getRdrName, nameRdrName ) +import qualified Name ( Name, mkInternalName, getName ) +import Module ( Module, mkModule ) +import RdrHsSyn ( mkClassDecl, mkTyData ) +import qualified OccName +import OccName ( startsVarId, startsVarSym, startsConId, startsConSym, + pprNameSpace ) +import SrcLoc ( Located(..), SrcSpan ) +import Type ( Type ) +import TysWiredIn ( unitTyCon, tupleTyCon, tupleCon, trueDataCon, nilDataCon, consDataCon ) +import BasicTypes( Boxity(..) ) +import ForeignCall ( Safety(..), CCallConv(..), CCallTarget(..), + CExportSpec(..)) +import Char ( isAscii, isAlphaNum, isAlpha ) +import List ( partition ) +import Unique ( Unique, mkUniqueGrimily ) +import ErrUtils ( Message ) +import GLAEXTS ( Int(..), Int# ) +import SrcLoc ( noSrcLoc ) +import Bag ( listToBag ) +import FastString +import Outputable + + + +------------------------------------------------------------------- +-- The external interface + +convertToHsDecls :: SrcSpan -> [TH.Dec] -> Either Message [LHsDecl RdrName] +convertToHsDecls loc ds = initCvt loc (mapM cvtTop ds) + +convertToHsExpr :: SrcSpan -> TH.Exp -> Either Message (LHsExpr RdrName) +convertToHsExpr loc e = initCvt loc (cvtl e) + +convertToHsType :: SrcSpan -> TH.Type -> Either Message (LHsType RdrName) +convertToHsType loc t = initCvt loc (cvtType t) + + +------------------------------------------------------------------- +newtype CvtM a = CvtM { unCvtM :: SrcSpan -> Either Message a } + -- Push down the source location; + -- Can fail, with a single error message + +-- NB: If the conversion succeeds with (Right x), there should +-- be no exception values hiding in x +-- Reason: so a (head []) in TH code doesn't subsequently +-- make GHC crash when it tries to walk the generated tree + +-- Use the loc everywhere, for lack of anything better +-- In particular, we want it on binding locations, so that variables bound in +-- the spliced-in declarations get a location that at least relates to the splice point + +instance Monad CvtM where + return x = CvtM $ \loc -> Right x + (CvtM m) >>= k = CvtM $ \loc -> case m loc of + Left err -> Left err + Right v -> unCvtM (k v) loc + +initCvt :: SrcSpan -> CvtM a -> Either Message a +initCvt loc (CvtM m) = m loc + +force :: a -> CvtM a +force a = a `seq` return a + +failWith :: Message -> CvtM a +failWith m = CvtM (\loc -> Left full_msg) + where + full_msg = m $$ ptext SLIT("When splicing generated code into the program") + +returnL :: a -> CvtM (Located a) +returnL x = CvtM (\loc -> Right (L loc x)) + +wrapL :: CvtM a -> CvtM (Located a) +wrapL (CvtM m) = CvtM (\loc -> case m loc of + Left err -> Left err + Right v -> Right (L loc v)) + +------------------------------------------------------------------- +cvtTop :: TH.Dec -> CvtM (LHsDecl RdrName) +cvtTop d@(TH.ValD _ _ _) = do { L loc d' <- cvtBind d; return (L loc $ Hs.ValD d') } +cvtTop d@(TH.FunD _ _) = do { L loc d' <- cvtBind d; return (L loc $ Hs.ValD d') } +cvtTop (TH.SigD nm typ) = do { nm' <- vNameL nm + ; ty' <- cvtType typ + ; returnL $ Hs.SigD (TypeSig nm' ty') } + +cvtTop (TySynD tc tvs rhs) + = do { tc' <- tconNameL tc + ; tvs' <- cvtTvs tvs + ; rhs' <- cvtType rhs + ; returnL $ TyClD (TySynonym tc' tvs' rhs') } + +cvtTop (DataD ctxt tc tvs constrs derivs) + = do { stuff <- cvt_tycl_hdr ctxt tc tvs + ; cons' <- mapM cvtConstr constrs + ; derivs' <- cvtDerivs derivs + ; returnL $ TyClD (mkTyData DataType stuff Nothing cons' derivs') } + + +cvtTop (NewtypeD ctxt tc tvs constr derivs) + = do { stuff <- cvt_tycl_hdr ctxt tc tvs + ; con' <- cvtConstr constr + ; derivs' <- cvtDerivs derivs + ; returnL $ TyClD (mkTyData NewType stuff Nothing [con'] derivs') } + +cvtTop (ClassD ctxt cl tvs fds decs) + = do { stuff <- cvt_tycl_hdr ctxt cl tvs + ; fds' <- mapM cvt_fundep fds + ; (binds', sigs') <- cvtBindsAndSigs decs + ; returnL $ TyClD $ mkClassDecl stuff fds' sigs' binds' } + +cvtTop (InstanceD tys ty decs) + = do { (binds', sigs') <- cvtBindsAndSigs decs + ; ctxt' <- cvtContext tys + ; L loc pred' <- cvtPred ty + ; inst_ty' <- returnL $ mkImplicitHsForAllTy ctxt' (L loc (HsPredTy pred')) + ; returnL $ InstD (InstDecl inst_ty' binds' sigs') } + +cvtTop (ForeignD ford) = do { ford' <- cvtForD ford; returnL $ ForD ford' } + +cvt_tycl_hdr cxt tc tvs + = do { cxt' <- cvtContext cxt + ; tc' <- tconNameL tc + ; tvs' <- cvtTvs tvs + ; return (cxt', tc', tvs') } + +--------------------------------------------------- +-- Data types +-- Can't handle GADTs yet +--------------------------------------------------- + +cvtConstr (NormalC c strtys) + = do { c' <- cNameL c + ; cxt' <- returnL [] + ; tys' <- mapM cvt_arg strtys + ; returnL $ ConDecl c' Explicit noExistentials cxt' (PrefixCon tys') ResTyH98 } + +cvtConstr (RecC c varstrtys) + = do { c' <- cNameL c + ; cxt' <- returnL [] + ; args' <- mapM cvt_id_arg varstrtys + ; returnL $ ConDecl c' Explicit noExistentials cxt' (RecCon args') ResTyH98 } + +cvtConstr (InfixC st1 c st2) + = do { c' <- cNameL c + ; cxt' <- returnL [] + ; st1' <- cvt_arg st1 + ; st2' <- cvt_arg st2 + ; returnL $ ConDecl c' Explicit noExistentials cxt' (InfixCon st1' st2') ResTyH98 } + +cvtConstr (ForallC tvs ctxt (ForallC tvs' ctxt' con')) + = cvtConstr (ForallC (tvs ++ tvs') (ctxt ++ ctxt') con') + +cvtConstr (ForallC tvs ctxt con) + = do { L _ con' <- cvtConstr con + ; tvs' <- cvtTvs tvs + ; ctxt' <- cvtContext ctxt + ; case con' of + ConDecl l _ [] (L _ []) x ResTyH98 + -> returnL $ ConDecl l Explicit tvs' ctxt' x ResTyH98 + c -> panic "ForallC: Can't happen" } + +cvt_arg (IsStrict, ty) = do { ty' <- cvtType ty; returnL $ HsBangTy HsStrict ty' } +cvt_arg (NotStrict, ty) = cvtType ty + +cvt_id_arg (i, str, ty) = do { i' <- vNameL i + ; ty' <- cvt_arg (str,ty) + ; return (i', ty') } + +cvtDerivs [] = return Nothing +cvtDerivs cs = do { cs' <- mapM cvt_one cs + ; return (Just cs') } + where + cvt_one c = do { c' <- tconName c + ; returnL $ HsPredTy $ HsClassP c' [] } + +cvt_fundep :: FunDep -> CvtM (Located (Class.FunDep RdrName)) +cvt_fundep (FunDep xs ys) = do { xs' <- mapM tName xs; ys' <- mapM tName ys; returnL (xs', ys') } + +noExistentials = [] + +------------------------------------------ +-- Foreign declarations +------------------------------------------ + +cvtForD :: Foreign -> CvtM (ForeignDecl RdrName) +cvtForD (ImportF callconv safety from nm ty) + | Just (c_header, cis) <- parse_ccall_impent (TH.nameBase nm) from + = do { nm' <- vNameL nm + ; ty' <- cvtType ty + ; let i = CImport (cvt_conv callconv) safety' c_header nilFS cis + ; return $ ForeignImport nm' ty' i False } + + | otherwise + = failWith $ text (show from)<+> ptext SLIT("is not a valid ccall impent") + where + safety' = case safety of + Unsafe -> PlayRisky + Safe -> PlaySafe False + Threadsafe -> PlaySafe True + +cvtForD (ExportF callconv as nm ty) + = do { nm' <- vNameL nm + ; ty' <- cvtType ty + ; let e = CExport (CExportStatic (mkFastString as) (cvt_conv callconv)) + ; return $ ForeignExport nm' ty' e False } + +cvt_conv CCall = CCallConv +cvt_conv StdCall = StdCallConv + +parse_ccall_impent :: String -> String -> Maybe (FastString, CImportSpec) +parse_ccall_impent nm s + = case lex_ccall_impent s of + Just ["dynamic"] -> Just (nilFS, CFunction DynamicTarget) + Just ["wrapper"] -> Just (nilFS, CWrapper) + Just ("static":ts) -> parse_ccall_impent_static nm ts + Just ts -> parse_ccall_impent_static nm ts + Nothing -> Nothing + +parse_ccall_impent_static :: String + -> [String] + -> Maybe (FastString, CImportSpec) +parse_ccall_impent_static nm ts + = let ts' = case ts of + [ "&", cid] -> [ cid] + [fname, "&" ] -> [fname ] + [fname, "&", cid] -> [fname, cid] + _ -> ts + in case ts' of + [ cid] | is_cid cid -> Just (nilFS, mk_cid cid) + [fname, cid] | is_cid cid -> Just (mkFastString fname, mk_cid cid) + [ ] -> Just (nilFS, mk_cid nm) + [fname ] -> Just (mkFastString fname, mk_cid nm) + _ -> Nothing + where is_cid :: String -> Bool + is_cid x = all (/= '.') x && (isAlpha (head x) || head x == '_') + mk_cid :: String -> CImportSpec + mk_cid = CFunction . StaticTarget . mkFastString + +lex_ccall_impent :: String -> Maybe [String] +lex_ccall_impent "" = Just [] +lex_ccall_impent ('&':xs) = fmap ("&":) $ lex_ccall_impent xs +lex_ccall_impent (' ':xs) = lex_ccall_impent xs +lex_ccall_impent ('\t':xs) = lex_ccall_impent xs +lex_ccall_impent xs = case span is_valid xs of + ("", _) -> Nothing + (t, xs') -> fmap (t:) $ lex_ccall_impent xs' + where is_valid :: Char -> Bool + is_valid c = isAscii c && (isAlphaNum c || c `elem` "._") + + +--------------------------------------------------- +-- Declarations +--------------------------------------------------- + +cvtDecs :: [TH.Dec] -> CvtM (HsLocalBinds RdrName) +cvtDecs [] = return EmptyLocalBinds +cvtDecs ds = do { (binds,sigs) <- cvtBindsAndSigs ds + ; return (HsValBinds (ValBindsIn binds sigs)) } + +cvtBindsAndSigs ds + = do { binds' <- mapM cvtBind binds; sigs' <- mapM cvtSig sigs + ; return (listToBag binds', sigs') } + where + (sigs, binds) = partition is_sig ds + + is_sig (TH.SigD _ _) = True + is_sig other = False + +cvtSig (TH.SigD nm ty) + = do { nm' <- vNameL nm; ty' <- cvtType ty; returnL (Hs.TypeSig nm' ty') } + +cvtBind :: TH.Dec -> CvtM (LHsBind RdrName) +-- Used only for declarations in a 'let/where' clause, +-- not for top level decls +cvtBind (TH.ValD (TH.VarP s) body ds) + = do { s' <- vNameL s + ; cl' <- cvtClause (Clause [] body ds) + ; returnL $ mkFunBind s' [cl'] } + +cvtBind (TH.FunD nm cls) + = do { nm' <- vNameL nm + ; cls' <- mapM cvtClause cls + ; returnL $ mkFunBind nm' cls' } + +cvtBind (TH.ValD p body ds) + = do { p' <- cvtPat p + ; g' <- cvtGuard body + ; ds' <- cvtDecs ds + ; returnL $ PatBind { pat_lhs = p', pat_rhs = GRHSs g' ds', + pat_rhs_ty = void, bind_fvs = placeHolderNames } } + +cvtBind d + = failWith (sep [ptext SLIT("Illegal kind of declaration in where clause"), + nest 2 (text (TH.pprint d))]) + +cvtClause :: TH.Clause -> CvtM (Hs.LMatch RdrName) +cvtClause (Clause ps body wheres) + = do { ps' <- cvtPats ps + ; g' <- cvtGuard body + ; ds' <- cvtDecs wheres + ; returnL $ Hs.Match ps' Nothing (GRHSs g' ds') } + + +------------------------------------------------------------------- +-- Expressions +------------------------------------------------------------------- + +cvtl :: TH.Exp -> CvtM (LHsExpr RdrName) +cvtl e = wrapL (cvt e) + where + cvt (VarE s) = do { s' <- vName s; return $ HsVar s' } + cvt (ConE s) = do { s' <- cName s; return $ HsVar s' } + cvt (LitE l) + | overloadedLit l = do { l' <- cvtOverLit l; return $ HsOverLit l' } + | otherwise = do { l' <- cvtLit l; return $ HsLit l' } + + cvt (AppE x y) = do { x' <- cvtl x; y' <- cvtl y; return $ HsApp x' y' } + cvt (LamE ps e) = do { ps' <- cvtPats ps; e' <- cvtl e + ; return $ HsLam (mkMatchGroup [mkSimpleMatch ps' e']) } + cvt (TupE [e]) = cvt e + cvt (TupE es) = do { es' <- mapM cvtl es; return $ ExplicitTuple es' Boxed } + cvt (CondE x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z + ; return $ HsIf x' y' z' } + cvt (LetE ds e) = do { ds' <- cvtDecs ds; e' <- cvtl e; return $ HsLet ds' e' } + cvt (CaseE e ms) = do { e' <- cvtl e; ms' <- mapM cvtMatch ms + ; return $ HsCase e' (mkMatchGroup ms') } + cvt (DoE ss) = cvtHsDo DoExpr ss + cvt (CompE ss) = cvtHsDo ListComp ss + cvt (ArithSeqE dd) = do { dd' <- cvtDD dd; return $ ArithSeq noPostTcExpr dd' } + cvt (ListE xs) = do { xs' <- mapM cvtl xs; return $ ExplicitList void xs' } + cvt (InfixE (Just x) s (Just y)) = do { x' <- cvtl x; s' <- cvtl s; y' <- cvtl y + ; e' <- returnL $ OpApp x' s' undefined y' + ; return $ HsPar e' } + cvt (InfixE Nothing s (Just y)) = do { s' <- cvtl s; y' <- cvtl y + ; return $ SectionR s' y' } + cvt (InfixE (Just x) s Nothing ) = do { x' <- cvtl x; s' <- cvtl s + ; return $ SectionL x' s' } + cvt (InfixE Nothing s Nothing ) = cvt s -- Can I indicate this is an infix thing? + + cvt (SigE e t) = do { e' <- cvtl e; t' <- cvtType t + ; return $ ExprWithTySig e' t' } + cvt (RecConE c flds) = do { c' <- cNameL c + ; flds' <- mapM cvtFld flds + ; return $ RecordCon c' noPostTcExpr flds' } + cvt (RecUpdE e flds) = do { e' <- cvtl e + ; flds' <- mapM cvtFld flds + ; return $ RecordUpd e' flds' placeHolderType placeHolderType } + +cvtFld (v,e) = do { v' <- vNameL v; e' <- cvtl e; return (v',e') } + +cvtDD :: Range -> CvtM (ArithSeqInfo RdrName) +cvtDD (FromR x) = do { x' <- cvtl x; return $ From x' } +cvtDD (FromThenR x y) = do { x' <- cvtl x; y' <- cvtl y; return $ FromThen x' y' } +cvtDD (FromToR x y) = do { x' <- cvtl x; y' <- cvtl y; return $ FromTo x' y' } +cvtDD (FromThenToR x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z; return $ FromThenTo x' y' z' } + +------------------------------------- +-- Do notation and statements +------------------------------------- + +cvtHsDo do_or_lc stmts + = do { stmts' <- cvtStmts stmts + ; let body = case last stmts' of + L _ (ExprStmt body _ _) -> body + ; return $ HsDo do_or_lc (init stmts') body void } + +cvtStmts = mapM cvtStmt + +cvtStmt :: TH.Stmt -> CvtM (Hs.LStmt RdrName) +cvtStmt (NoBindS e) = do { e' <- cvtl e; returnL $ mkExprStmt e' } +cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnL $ mkBindStmt p' e' } +cvtStmt (TH.LetS ds) = do { ds' <- cvtDecs ds; returnL $ LetStmt ds' } +cvtStmt (TH.ParS dss) = do { dss' <- mapM cvt_one dss; returnL $ ParStmt dss' } + where + cvt_one ds = do { ds' <- cvtStmts ds; return (ds', undefined) } + +cvtMatch :: TH.Match -> CvtM (Hs.LMatch RdrName) +cvtMatch (TH.Match p body decs) + = do { p' <- cvtPat p + ; g' <- cvtGuard body + ; decs' <- cvtDecs decs + ; returnL $ Hs.Match [p'] Nothing (GRHSs g' decs') } + +cvtGuard :: TH.Body -> CvtM [LGRHS RdrName] +cvtGuard (GuardedB pairs) = mapM cvtpair pairs +cvtGuard (NormalB e) = do { e' <- cvtl e; g' <- returnL $ GRHS [] e'; return [g'] } + +cvtpair :: (TH.Guard, TH.Exp) -> CvtM (LGRHS RdrName) +cvtpair (NormalG ge,rhs) = do { ge' <- cvtl ge; rhs' <- cvtl rhs + ; g' <- returnL $ mkBindStmt truePat ge' + ; returnL $ GRHS [g'] rhs' } +cvtpair (PatG gs,rhs) = do { gs' <- cvtStmts gs; rhs' <- cvtl rhs + ; returnL $ GRHS gs' rhs' } + +cvtOverLit :: Lit -> CvtM (HsOverLit RdrName) +cvtOverLit (IntegerL i) = do { force i; return $ mkHsIntegral i } +cvtOverLit (RationalL r) = do { force r; return $ mkHsFractional r } +-- An Integer is like an an (overloaded) '3' in a Haskell source program +-- Similarly 3.5 for fractionals + +cvtLit :: Lit -> CvtM HsLit +cvtLit (IntPrimL i) = do { force i; return $ HsIntPrim i } +cvtLit (FloatPrimL f) = do { force f; return $ HsFloatPrim f } +cvtLit (DoublePrimL f) = do { force f; return $ HsDoublePrim f } +cvtLit (CharL c) = do { force c; return $ HsChar c } +cvtLit (StringL s) = do { let { s' = mkFastString s }; force s'; return $ HsString s' } + +cvtPats :: [TH.Pat] -> CvtM [Hs.LPat RdrName] +cvtPats pats = mapM cvtPat pats + +cvtPat :: TH.Pat -> CvtM (Hs.LPat RdrName) +cvtPat pat = wrapL (cvtp pat) + +cvtp :: TH.Pat -> CvtM (Hs.Pat RdrName) +cvtp (TH.LitP l) + | overloadedLit l = do { l' <- cvtOverLit l + ; return (mkNPat l' Nothing) } + -- Not right for negative patterns; + -- need to think about that! + | otherwise = do { l' <- cvtLit l; return $ Hs.LitPat l' } +cvtp (TH.VarP s) = do { s' <- vName s; return $ Hs.VarPat s' } +cvtp (TupP [p]) = cvtp p +cvtp (TupP ps) = do { ps' <- cvtPats ps; return $ TuplePat ps' Boxed void } +cvtp (ConP s ps) = do { s' <- cNameL s; ps' <- cvtPats ps; return $ ConPatIn s' (PrefixCon ps') } +cvtp (InfixP p1 s p2) = do { s' <- cNameL s; p1' <- cvtPat p1; p2' <- cvtPat p2 + ; return $ ConPatIn s' (InfixCon p1' p2') } +cvtp (TildeP p) = do { p' <- cvtPat p; return $ LazyPat p' } +cvtp (TH.AsP s p) = do { s' <- vNameL s; p' <- cvtPat p; return $ AsPat s' p' } +cvtp TH.WildP = return $ WildPat void +cvtp (RecP c fs) = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs + ; return $ ConPatIn c' $ Hs.RecCon fs' } +cvtp (ListP ps) = do { ps' <- cvtPats ps; return $ ListPat ps' void } +cvtp (SigP p t) = do { p' <- cvtPat p; t' <- cvtType t; return $ SigPatIn p' t' } + +cvtPatFld (s,p) = do { s' <- vNameL s; p' <- cvtPat p; return (s',p') } + +----------------------------------------------------------- +-- Types and type variables + +cvtTvs :: [TH.Name] -> CvtM [LHsTyVarBndr RdrName] +cvtTvs tvs = mapM cvt_tv tvs + +cvt_tv tv = do { tv' <- tName tv; returnL $ UserTyVar tv' } + +cvtContext :: Cxt -> CvtM (LHsContext RdrName) +cvtContext tys = do { preds' <- mapM cvtPred tys; returnL preds' } + +cvtPred :: TH.Type -> CvtM (LHsPred RdrName) +cvtPred ty + = do { (head, tys') <- split_ty_app ty + ; case head of + ConT tc -> do { tc' <- tconName tc; returnL $ HsClassP tc' tys' } + VarT tv -> do { tv' <- tName tv; returnL $ HsClassP tv' tys' } + other -> failWith (ptext SLIT("Malformed predicate") <+> text (TH.pprint ty)) } + +cvtType :: TH.Type -> CvtM (LHsType RdrName) +cvtType ty = do { (head, tys') <- split_ty_app ty + ; case head of + TupleT n | length tys' == n -> returnL (HsTupleTy Boxed tys') + | n == 0 -> mk_apps (HsTyVar (getRdrName unitTyCon)) tys' + | otherwise -> mk_apps (HsTyVar (getRdrName (tupleTyCon Boxed n))) tys' + ArrowT | [x',y'] <- tys' -> returnL (HsFunTy x' y') + ListT | [x'] <- tys' -> returnL (HsListTy x') + VarT nm -> do { nm' <- tName nm; mk_apps (HsTyVar nm') tys' } + ConT nm -> do { nm' <- tconName nm; mk_apps (HsTyVar nm') tys' } + + ForallT tvs cxt ty | null tys' -> do { tvs' <- cvtTvs tvs + ; cxt' <- cvtContext cxt + ; ty' <- cvtType ty + ; returnL $ mkExplicitHsForAllTy tvs' cxt' ty' } + otherwise -> failWith (ptext SLIT("Malformed type") <+> text (show ty)) + } + where + mk_apps head [] = returnL head + mk_apps head (ty:tys) = do { head' <- returnL head; mk_apps (HsAppTy head' ty) tys } + +split_ty_app :: TH.Type -> CvtM (TH.Type, [LHsType RdrName]) +split_ty_app ty = go ty [] + where + go (AppT f a) as' = do { a' <- cvtType a; go f (a':as') } + go f as = return (f,as) + +----------------------------------------------------------- + + +----------------------------------------------------------- +-- some useful things + +truePat = nlConPat (getRdrName trueDataCon) [] + +overloadedLit :: Lit -> Bool +-- True for literals that Haskell treats as overloaded +overloadedLit (IntegerL l) = True +overloadedLit (RationalL l) = True +overloadedLit l = False + +void :: Type.Type +void = placeHolderType + +-------------------------------------------------------------------- +-- Turning Name back into RdrName +-------------------------------------------------------------------- + +-- variable names +vNameL, cNameL, tconNameL :: TH.Name -> CvtM (Located RdrName) +vName, cName, tName, tconName :: TH.Name -> CvtM RdrName + +vNameL n = wrapL (vName n) +vName n = cvtName OccName.varName n + +-- Constructor function names; this is Haskell source, hence srcDataName +cNameL n = wrapL (cName n) +cName n = cvtName OccName.dataName n + +-- Type variable names +tName n = cvtName OccName.tvName n + +-- Type Constructor names +tconNameL n = wrapL (tconName n) +tconName n = cvtName OccName.tcClsName n + +cvtName :: OccName.NameSpace -> TH.Name -> CvtM RdrName +cvtName ctxt_ns (TH.Name occ flavour) + | not (okOcc ctxt_ns occ_str) = failWith (badOcc ctxt_ns occ_str) + | otherwise = force (thRdrName ctxt_ns occ_str flavour) + where + occ_str = TH.occString occ + +okOcc :: OccName.NameSpace -> String -> Bool +okOcc _ [] = False +okOcc ns str@(c:_) + | OccName.isVarName ns = startsVarId c || startsVarSym c + | otherwise = startsConId c || startsConSym c || str == "[]" + +badOcc :: OccName.NameSpace -> String -> SDoc +badOcc ctxt_ns occ + = ptext SLIT("Illegal") <+> pprNameSpace ctxt_ns + <+> ptext SLIT("name:") <+> quotes (text occ) + +thRdrName :: OccName.NameSpace -> String -> TH.NameFlavour -> RdrName +-- This turns a Name into a RdrName +-- The passed-in name space tells what the context is expecting; +-- use it unless the TH name knows what name-space it comes +-- from, in which case use the latter +-- +-- ToDo: we may generate silly RdrNames, by passing a name space +-- that doesn't match the string, like VarName ":+", +-- which will give confusing error messages later +-- +-- The strict applications ensure that any buried exceptions get forced +thRdrName ctxt_ns occ (TH.NameG th_ns mod) = (mkOrig $! (mk_mod mod)) $! (mk_occ (mk_ghc_ns th_ns) occ) +thRdrName ctxt_ns occ (TH.NameL uniq) = nameRdrName $! (((Name.mkInternalName $! (mk_uniq uniq)) $! (mk_occ ctxt_ns occ)) noSrcLoc) +thRdrName ctxt_ns occ (TH.NameQ mod) = (mkRdrQual $! (mk_mod mod)) $! (mk_occ ctxt_ns occ) +thRdrName ctxt_ns occ (TH.NameU uniq) = mkRdrUnqual $! (mk_uniq_occ ctxt_ns occ uniq) +thRdrName ctxt_ns occ TH.NameS + | Just name <- isBuiltInOcc ctxt_ns occ = nameRdrName $! name + | otherwise = mkRdrUnqual $! (mk_occ ctxt_ns occ) + +isBuiltInOcc :: OccName.NameSpace -> String -> Maybe Name.Name +-- Built in syntax isn't "in scope" so an Unqual RdrName won't do +-- We must generate an Exact name, just as the parser does +isBuiltInOcc ctxt_ns occ + = case occ of + ":" -> Just (Name.getName consDataCon) + "[]" -> Just (Name.getName nilDataCon) + "()" -> Just (tup_name 0) + '(' : ',' : rest -> go_tuple 2 rest + other -> Nothing + where + go_tuple n ")" = Just (tup_name n) + go_tuple n (',' : rest) = go_tuple (n+1) rest + go_tuple n other = Nothing + + tup_name n + | OccName.isTcClsName ctxt_ns = Name.getName (tupleTyCon Boxed n) + | otherwise = Name.getName (tupleCon Boxed n) + +mk_uniq_occ :: OccName.NameSpace -> String -> Int# -> OccName.OccName +mk_uniq_occ ns occ uniq + = OccName.mkOccName ns (occ ++ '[' : shows (mk_uniq uniq) "]") + -- The idea here is to make a name that + -- a) the user could not possibly write, and + -- b) cannot clash with another NameU + -- Previously I generated an Exact RdrName with mkInternalName. + -- This works fine for local binders, but does not work at all for + -- top-level binders, which must have External Names, since they are + -- rapidly baked into data constructors and the like. Baling out + -- and generating an unqualified RdrName here is the simple solution + +-- The packing and unpacking is rather turgid :-( +mk_occ :: OccName.NameSpace -> String -> OccName.OccName +mk_occ ns occ = OccName.mkOccNameFS ns (mkFastString occ) + +mk_ghc_ns :: TH.NameSpace -> OccName.NameSpace +mk_ghc_ns TH.DataName = OccName.dataName +mk_ghc_ns TH.TcClsName = OccName.tcClsName +mk_ghc_ns TH.VarName = OccName.varName + +mk_mod :: TH.ModName -> Module +mk_mod mod = mkModule (TH.modString mod) + +mk_uniq :: Int# -> Unique +mk_uniq u = mkUniqueGrimily (I# u) +\end{code} + diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs new file mode 100644 index 0000000000..b5c21792af --- /dev/null +++ b/compiler/hsSyn/HsBinds.lhs @@ -0,0 +1,479 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +% +\section[HsBinds]{Abstract syntax: top-level bindings and signatures} + +Datatype for: @BindGroup@, @Bind@, @Sig@, @Bind@. + +\begin{code} +module HsBinds where + +#include "HsVersions.h" + +import {-# SOURCE #-} HsExpr ( HsExpr, pprExpr, LHsExpr, + MatchGroup, pprFunBind, + GRHSs, pprPatBind ) +import {-# SOURCE #-} HsPat ( LPat ) + +import HsTypes ( LHsType, PostTcType ) +import Type ( Type ) +import Name ( Name ) +import NameSet ( NameSet, elemNameSet ) +import BasicTypes ( IPName, RecFlag(..), InlineSpec(..), Fixity ) +import Outputable +import SrcLoc ( Located(..), SrcSpan, unLoc ) +import Util ( sortLe ) +import Var ( TyVar, DictId, Id ) +import Bag ( Bag, emptyBag, isEmptyBag, bagToList, unionBags, unionManyBags ) +\end{code} + +%************************************************************************ +%* * +\subsection{Bindings: @BindGroup@} +%* * +%************************************************************************ + +Global bindings (where clauses) + +\begin{code} +data HsLocalBinds id -- Bindings in a 'let' expression + -- or a 'where' clause + = HsValBinds (HsValBinds id) + | HsIPBinds (HsIPBinds id) + + | EmptyLocalBinds + +data HsValBinds id -- Value bindings (not implicit parameters) + = ValBindsIn -- Before typechecking + (LHsBinds id) [LSig id] -- Not dependency analysed + -- Recursive by default + + | ValBindsOut -- After renaming + [(RecFlag, LHsBinds id)] -- Dependency analysed + [LSig Name] + +type LHsBinds id = Bag (LHsBind id) +type DictBinds id = LHsBinds id -- Used for dictionary or method bindings +type LHsBind id = Located (HsBind id) + +data HsBind id + = FunBind { -- FunBind is used for both functions f x = e + -- and variables f = \x -> e +-- Reason 1: the Match stuff lets us have an optional +-- result type sig f :: a->a = ...mentions a... +-- +-- Reason 2: Special case for type inference: see TcBinds.tcMonoBinds +-- +-- Reason 3: instance decls can only have FunBinds, which is convenient +-- If you change this, you'll need tochange e.g. rnMethodBinds + + fun_id :: Located id, + + fun_infix :: Bool, -- True => infix declaration + + fun_matches :: MatchGroup id, -- The payload + + fun_co_fn :: ExprCoFn, -- Coercion from the type of the MatchGroup to the type of + -- the Id. Example: + -- f :: Int -> forall a. a -> a + -- f x y = y + -- Then the MatchGroup will have type (Int -> a' -> a') + -- (with a free type variable a'). The coercion will take + -- a CoreExpr of this type and convert it to a CoreExpr of + -- type Int -> forall a'. a' -> a' + -- Notice that the coercion captures the free a'. That's + -- why coercions are (CoreExpr -> CoreExpr), rather than + -- just CoreExpr (with a functional type) + + bind_fvs :: NameSet -- After the renamer, this contains a superset of the + -- Names of the other binders in this binding group that + -- are free in the RHS of the defn + -- Before renaming, and after typechecking, + -- the field is unused; it's just an error thunk + } + + | PatBind { -- The pattern is never a simple variable; + -- That case is done by FunBind + pat_lhs :: LPat id, + pat_rhs :: GRHSs id, + pat_rhs_ty :: PostTcType, -- Type of the GRHSs + bind_fvs :: NameSet -- Same as for FunBind + } + + | VarBind { -- Dictionary binding and suchlike + var_id :: id, -- All VarBinds are introduced by the type checker + var_rhs :: LHsExpr id -- Located only for consistency + } + + | AbsBinds { -- Binds abstraction; TRANSLATION + abs_tvs :: [TyVar], + abs_dicts :: [DictId], + abs_exports :: [([TyVar], id, id, [Prag])], -- (tvs, poly_id, mono_id, prags) + abs_binds :: LHsBinds id -- The dictionary bindings and typechecked user bindings + -- mixed up together; you can tell the dict bindings because + -- they are all VarBinds + } + -- Consider (AbsBinds tvs ds [(ftvs, poly_f, mono_f) binds] + -- + -- Creates bindings for (polymorphic, overloaded) poly_f + -- in terms of monomorphic, non-overloaded mono_f + -- + -- Invariants: + -- 1. 'binds' binds mono_f + -- 2. ftvs is a subset of tvs + -- 3. ftvs includes all tyvars free in ds + -- + -- See section 9 of static semantics paper for more details. + -- (You can get a PhD for explaining the True Meaning + -- of this last construct.) + +placeHolderNames :: NameSet +-- Used for the NameSet in FunBind and PatBind prior to the renamer +placeHolderNames = panic "placeHolderNames" + +------------ +instance OutputableBndr id => Outputable (HsLocalBinds id) where + ppr (HsValBinds bs) = ppr bs + ppr (HsIPBinds bs) = ppr bs + ppr EmptyLocalBinds = empty + +instance OutputableBndr id => Outputable (HsValBinds id) where + ppr (ValBindsIn binds sigs) + = pprValBindsForUser binds sigs + + ppr (ValBindsOut sccs sigs) + = getPprStyle $ \ sty -> + if debugStyle sty then -- Print with sccs showing + vcat (map ppr sigs) $$ vcat (map ppr_scc sccs) + else + pprValBindsForUser (unionManyBags (map snd sccs)) sigs + where + ppr_scc (rec_flag, binds) = pp_rec rec_flag <+> pprLHsBinds binds + pp_rec Recursive = ptext SLIT("rec") + pp_rec NonRecursive = ptext SLIT("nonrec") + +-- *not* pprLHsBinds because we don't want braces; 'let' and +-- 'where' include a list of HsBindGroups and we don't want +-- several groups of bindings each with braces around. +-- Sort by location before printing +pprValBindsForUser binds sigs + = vcat (map snd (sort_by_loc decls)) + where + + decls :: [(SrcSpan, SDoc)] + decls = [(loc, ppr sig) | L loc sig <- sigs] ++ + [(loc, ppr bind) | L loc bind <- bagToList binds] + + sort_by_loc decls = sortLe (\(l1,_) (l2,_) -> l1 <= l2) decls + +pprLHsBinds :: OutputableBndr id => LHsBinds id -> SDoc +pprLHsBinds binds + | isEmptyLHsBinds binds = empty + | otherwise = lbrace <+> vcat (map ppr (bagToList binds)) <+> rbrace + +------------ +emptyLocalBinds :: HsLocalBinds a +emptyLocalBinds = EmptyLocalBinds + +isEmptyLocalBinds :: HsLocalBinds a -> Bool +isEmptyLocalBinds (HsValBinds ds) = isEmptyValBinds ds +isEmptyLocalBinds (HsIPBinds ds) = isEmptyIPBinds ds +isEmptyLocalBinds EmptyLocalBinds = True + +isEmptyValBinds :: HsValBinds a -> Bool +isEmptyValBinds (ValBindsIn ds sigs) = isEmptyLHsBinds ds && null sigs +isEmptyValBinds (ValBindsOut ds sigs) = null ds && null sigs + +emptyValBindsIn, emptyValBindsOut :: HsValBinds a +emptyValBindsIn = ValBindsIn emptyBag [] +emptyValBindsOut = ValBindsOut [] [] + +emptyLHsBinds :: LHsBinds id +emptyLHsBinds = emptyBag + +isEmptyLHsBinds :: LHsBinds id -> Bool +isEmptyLHsBinds = isEmptyBag + +------------ +plusHsValBinds :: HsValBinds a -> HsValBinds a -> HsValBinds a +plusHsValBinds (ValBindsIn ds1 sigs1) (ValBindsIn ds2 sigs2) + = ValBindsIn (ds1 `unionBags` ds2) (sigs1 ++ sigs2) +plusHsValBinds (ValBindsOut ds1 sigs1) (ValBindsOut ds2 sigs2) + = ValBindsOut (ds1 ++ ds2) (sigs1 ++ sigs2) +\end{code} + +What AbsBinds means +~~~~~~~~~~~~~~~~~~~ + AbsBinds tvs + [d1,d2] + [(tvs1, f1p, f1m), + (tvs2, f2p, f2m)] + BIND +means + + f1p = /\ tvs -> \ [d1,d2] -> letrec DBINDS and BIND + in fm + + gp = ...same again, with gm instead of fm + +This is a pretty bad translation, because it duplicates all the bindings. +So the desugarer tries to do a better job: + + fp = /\ [a,b] -> \ [d1,d2] -> case tp [a,b] [d1,d2] of + (fm,gm) -> fm + ..ditto for gp.. + + tp = /\ [a,b] -> \ [d1,d2] -> letrec DBINDS and BIND + in (fm,gm) + +\begin{code} +instance OutputableBndr id => Outputable (HsBind id) where + ppr mbind = ppr_monobind mbind + +ppr_monobind :: OutputableBndr id => HsBind id -> SDoc + +ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss }) = pprPatBind pat grhss +ppr_monobind (VarBind { var_id = var, var_rhs = rhs }) = ppr var <+> equals <+> pprExpr (unLoc rhs) +ppr_monobind (FunBind { fun_id = fun, fun_matches = matches }) = pprFunBind (unLoc fun) matches + -- ToDo: print infix if appropriate + +ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_dicts = dictvars, + abs_exports = exports, abs_binds = val_binds }) + = sep [ptext SLIT("AbsBinds"), + brackets (interpp'SP tyvars), + brackets (interpp'SP dictvars), + brackets (sep (punctuate comma (map ppr_exp exports)))] + $$ + nest 2 ( vcat [pprBndr LetBind x | (_,x,_,_) <- exports] + -- Print type signatures + $$ pprLHsBinds val_binds ) + where + ppr_exp (tvs, gbl, lcl, prags) + = vcat [ppr gbl <+> ptext SLIT("<=") <+> ppr tvs <+> ppr lcl, + nest 2 (vcat (map (pprPrag gbl) prags))] +\end{code} + +%************************************************************************ +%* * + Implicit parameter bindings +%* * +%************************************************************************ + +\begin{code} +data HsIPBinds id + = IPBinds + [LIPBind id] + (DictBinds id) -- Only in typechecker output; binds + -- uses of the implicit parameters + +isEmptyIPBinds :: HsIPBinds id -> Bool +isEmptyIPBinds (IPBinds is ds) = null is && isEmptyBag ds + +type LIPBind id = Located (IPBind id) + +-- | Implicit parameter bindings. +data IPBind id + = IPBind + (IPName id) + (LHsExpr id) + +instance (OutputableBndr id) => Outputable (HsIPBinds id) where + ppr (IPBinds bs ds) = vcat (map ppr bs) + $$ pprLHsBinds ds + +instance (OutputableBndr id) => Outputable (IPBind id) where + ppr (IPBind id rhs) = pprBndr LetBind id <+> equals <+> pprExpr (unLoc rhs) +\end{code} + + +%************************************************************************ +%* * +\subsection{Coercion functions} +%* * +%************************************************************************ + +\begin{code} +-- A Coercion is an expression with a hole in it +-- We need coercions to have concrete form so that we can zonk them + +data ExprCoFn + = CoHole -- The identity coercion + | CoCompose ExprCoFn ExprCoFn + | CoApps ExprCoFn [Id] -- Non-empty list + | CoTyApps ExprCoFn [Type] -- in all of these + | CoLams [Id] ExprCoFn -- so that the identity coercion + | CoTyLams [TyVar] ExprCoFn -- is just Hole + | CoLet (LHsBinds Id) ExprCoFn -- Would be nicer to be core bindings + +(<.>) :: ExprCoFn -> ExprCoFn -> ExprCoFn +(<.>) = CoCompose + +idCoercion :: ExprCoFn +idCoercion = CoHole + +isIdCoercion :: ExprCoFn -> Bool +isIdCoercion CoHole = True +isIdCoercion other = False +\end{code} + + +%************************************************************************ +%* * +\subsection{@Sig@: type signatures and value-modifying user pragmas} +%* * +%************************************************************************ + +It is convenient to lump ``value-modifying'' user-pragmas (e.g., +``specialise this function to these four types...'') in with type +signatures. Then all the machinery to move them into place, etc., +serves for both. + +\begin{code} +type LSig name = Located (Sig name) + +data Sig name + = TypeSig (Located name) -- A bog-std type signature + (LHsType name) + + | SpecSig (Located name) -- Specialise a function or datatype ... + (LHsType name) -- ... to these types + InlineSpec + + | InlineSig (Located name) -- Function name + InlineSpec + + | SpecInstSig (LHsType name) -- (Class tys); should be a specialisation of the + -- current instance decl + + | FixSig (FixitySig name) -- Fixity declaration + +type LFixitySig name = Located (FixitySig name) +data FixitySig name = FixitySig (Located name) Fixity + +-- A Prag conveys pragmas from the type checker to the desugarer +data Prag + = InlinePrag + InlineSpec + + | SpecPrag + (HsExpr Id) -- An expression, of the given specialised type, which + PostTcType -- specialises the polymorphic function + [Id] -- Dicts mentioned free in the expression + InlineSpec -- Inlining spec for the specialised function + +isInlinePrag (InlinePrag _) = True +isInlinePrag prag = False + +isSpecPrag (SpecPrag _ _ _ _) = True +isSpecPrag prag = False +\end{code} + +\begin{code} +okBindSig :: NameSet -> LSig Name -> Bool +okBindSig ns sig = sigForThisGroup ns sig + +okHsBootSig :: LSig Name -> Bool +okHsBootSig (L _ (TypeSig _ _)) = True +okHsBootSig (L _ (FixSig _)) = True +okHsBootSig sig = False + +okClsDclSig :: LSig Name -> Bool +okClsDclSig (L _ (SpecInstSig _)) = False +okClsDclSig sig = True -- All others OK + +okInstDclSig :: NameSet -> LSig Name -> Bool +okInstDclSig ns lsig@(L _ sig) = ok ns sig + where + ok ns (TypeSig _ _) = False + ok ns (FixSig _) = False + ok ns (SpecInstSig _) = True + ok ns sig = sigForThisGroup ns lsig + +sigForThisGroup :: NameSet -> LSig Name -> Bool +sigForThisGroup ns sig + = case sigName sig of + Nothing -> False + Just n -> n `elemNameSet` ns + +sigName :: LSig name -> Maybe name +sigName (L _ sig) = f sig + where + f (TypeSig n _) = Just (unLoc n) + f (SpecSig n _ _) = Just (unLoc n) + f (InlineSig n _) = Just (unLoc n) + f (FixSig (FixitySig n _)) = Just (unLoc n) + f other = Nothing + +isFixityLSig :: LSig name -> Bool +isFixityLSig (L _ (FixSig {})) = True +isFixityLSig _ = False + +isVanillaLSig :: LSig name -> Bool +isVanillaLSig (L _(TypeSig {})) = True +isVanillaLSig sig = False + +isSpecLSig :: LSig name -> Bool +isSpecLSig (L _(SpecSig {})) = True +isSpecLSig sig = False + +isSpecInstLSig (L _ (SpecInstSig {})) = True +isSpecInstLSig sig = False + +isPragLSig :: LSig name -> Bool + -- Identifies pragmas +isPragLSig (L _ (SpecSig {})) = True +isPragLSig (L _ (InlineSig {})) = True +isPragLSig other = False + +isInlineLSig :: LSig name -> Bool + -- Identifies inline pragmas +isInlineLSig (L _ (InlineSig {})) = True +isInlineLSig other = False + +hsSigDoc (TypeSig {}) = ptext SLIT("type signature") +hsSigDoc (SpecSig {}) = ptext SLIT("SPECIALISE pragma") +hsSigDoc (InlineSig _ spec) = ppr spec <+> ptext SLIT("pragma") +hsSigDoc (SpecInstSig {}) = ptext SLIT("SPECIALISE instance pragma") +hsSigDoc (FixSig {}) = ptext SLIT("fixity declaration") +\end{code} + +Signature equality is used when checking for duplicate signatures + +\begin{code} +eqHsSig :: LSig Name -> LSig Name -> Bool +eqHsSig (L _ (FixSig (FixitySig n1 _))) (L _ (FixSig (FixitySig n2 _))) = unLoc n1 == unLoc n2 +eqHsSig (L _ (TypeSig n1 _)) (L _ (TypeSig n2 _)) = unLoc n1 == unLoc n2 +eqHsSig (L _ (InlineSig n1 s1)) (L _ (InlineSig n2 s2)) = s1 == s2 && unLoc n1 == unLoc n2 + -- For specialisations, we don't have equality over + -- HsType, so it's not convenient to spot duplicate + -- specialisations here. Check for this later, when we're in Type land +eqHsSig _other1 _other2 = False +\end{code} + +\begin{code} +instance (OutputableBndr name) => Outputable (Sig name) where + ppr sig = ppr_sig sig + +ppr_sig :: OutputableBndr name => Sig name -> SDoc +ppr_sig (TypeSig var ty) = pprVarSig (unLoc var) ty +ppr_sig (FixSig fix_sig) = ppr fix_sig +ppr_sig (SpecSig var ty inl) = pragBrackets (pprSpec var ty inl) +ppr_sig (InlineSig var inl) = pragBrackets (ppr inl <+> ppr var) +ppr_sig (SpecInstSig ty) = pragBrackets (ptext SLIT("SPECIALIZE instance") <+> ppr ty) + +instance Outputable name => Outputable (FixitySig name) where + ppr (FixitySig name fixity) = sep [ppr fixity, ppr name] + +pragBrackets :: SDoc -> SDoc +pragBrackets doc = ptext SLIT("{-#") <+> doc <+> ptext SLIT("#-}") + +pprVarSig :: (Outputable id, Outputable ty) => id -> ty -> SDoc +pprVarSig var ty = sep [ppr var <+> dcolon, nest 2 (ppr ty)] + +pprSpec :: (Outputable id, Outputable ty) => id -> ty -> InlineSpec -> SDoc +pprSpec var ty inl = sep [ptext SLIT("SPECIALIZE") <+> ppr inl <+> pprVarSig var ty] + +pprPrag :: Outputable id => id -> Prag -> SDoc +pprPrag var (InlinePrag inl) = ppr inl <+> ppr var +pprPrag var (SpecPrag expr ty _ inl) = pprSpec var ty inl +\end{code} diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs new file mode 100644 index 0000000000..8ff39857c6 --- /dev/null +++ b/compiler/hsSyn/HsDecls.lhs @@ -0,0 +1,796 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +% +\section[HsDecls]{Abstract syntax: global declarations} + +Definitions for: @TyDecl@ and @oCnDecl@, @ClassDecl@, +@InstDecl@, @DefaultDecl@ and @ForeignDecl@. + +\begin{code} +module HsDecls ( + HsDecl(..), LHsDecl, TyClDecl(..), LTyClDecl, + InstDecl(..), LInstDecl, NewOrData(..), + RuleDecl(..), LRuleDecl, RuleBndr(..), + DefaultDecl(..), LDefaultDecl, SpliceDecl(..), + ForeignDecl(..), LForeignDecl, ForeignImport(..), ForeignExport(..), + CImportSpec(..), FoType(..), + ConDecl(..), ResType(..), LConDecl, + DeprecDecl(..), LDeprecDecl, + HsGroup(..), emptyRdrGroup, emptyRnGroup, appendGroups, + tcdName, tyClDeclNames, tyClDeclTyVars, + isClassDecl, isSynDecl, isDataDecl, + countTyClDecls, + conDetailsTys, + collectRuleBndrSigTys, + ) where + +#include "HsVersions.h" + +-- friends: +import {-# SOURCE #-} HsExpr( HsExpr, pprExpr ) + -- Because Expr imports Decls via HsBracket + +import HsBinds ( HsValBinds(..), HsBind, LHsBinds, plusHsValBinds, + Sig(..), LSig, LFixitySig, pprLHsBinds, + emptyValBindsIn, emptyValBindsOut ) +import HsPat ( HsConDetails(..), hsConArgs ) +import HsImpExp ( pprHsVar ) +import HsTypes +import NameSet ( NameSet ) +import HscTypes ( DeprecTxt ) +import CoreSyn ( RuleName ) +import Kind ( Kind, pprKind ) +import BasicTypes ( Activation(..) ) +import ForeignCall ( CCallTarget(..), DNCallSpec, CCallConv, Safety, + CExportSpec(..), CLabelString ) + +-- others: +import FunDeps ( pprFundeps ) +import Class ( FunDep ) +import Outputable +import Util ( count ) +import SrcLoc ( Located(..), unLoc, noLoc ) +import FastString +\end{code} + + +%************************************************************************ +%* * +\subsection[HsDecl]{Declarations} +%* * +%************************************************************************ + +\begin{code} +type LHsDecl id = Located (HsDecl id) + +data HsDecl id + = TyClD (TyClDecl id) + | InstD (InstDecl id) + | ValD (HsBind id) + | SigD (Sig id) + | DefD (DefaultDecl id) + | ForD (ForeignDecl id) + | DeprecD (DeprecDecl id) + | RuleD (RuleDecl id) + | SpliceD (SpliceDecl id) + +-- NB: all top-level fixity decls are contained EITHER +-- EITHER SigDs +-- OR in the ClassDecls in TyClDs +-- +-- The former covers +-- a) data constructors +-- b) class methods (but they can be also done in the +-- signatures of class decls) +-- c) imported functions (that have an IfacSig) +-- d) top level decls +-- +-- The latter is for class methods only + +-- A [HsDecl] is categorised into a HsGroup before being +-- fed to the renamer. +data HsGroup id + = HsGroup { + hs_valds :: HsValBinds id, + hs_tyclds :: [LTyClDecl id], + hs_instds :: [LInstDecl id], + + hs_fixds :: [LFixitySig id], + -- Snaffled out of both top-level fixity signatures, + -- and those in class declarations + + hs_defds :: [LDefaultDecl id], + hs_fords :: [LForeignDecl id], + hs_depds :: [LDeprecDecl id], + hs_ruleds :: [LRuleDecl id] + } + +emptyGroup, emptyRdrGroup, emptyRnGroup :: HsGroup a +emptyRdrGroup = emptyGroup { hs_valds = emptyValBindsIn } +emptyRnGroup = emptyGroup { hs_valds = emptyValBindsOut } + +emptyGroup = HsGroup { hs_tyclds = [], hs_instds = [], + hs_fixds = [], hs_defds = [], hs_fords = [], + hs_depds = [], hs_ruleds = [], + hs_valds = error "emptyGroup hs_valds: Can't happen" } + +appendGroups :: HsGroup a -> HsGroup a -> HsGroup a +appendGroups + HsGroup { + hs_valds = val_groups1, + hs_tyclds = tyclds1, + hs_instds = instds1, + hs_fixds = fixds1, + hs_defds = defds1, + hs_fords = fords1, + hs_depds = depds1, + hs_ruleds = rulds1 } + HsGroup { + hs_valds = val_groups2, + hs_tyclds = tyclds2, + hs_instds = instds2, + hs_fixds = fixds2, + hs_defds = defds2, + hs_fords = fords2, + hs_depds = depds2, + hs_ruleds = rulds2 } + = + HsGroup { + hs_valds = val_groups1 `plusHsValBinds` val_groups2, + hs_tyclds = tyclds1 ++ tyclds2, + hs_instds = instds1 ++ instds2, + hs_fixds = fixds1 ++ fixds2, + hs_defds = defds1 ++ defds2, + hs_fords = fords1 ++ fords2, + hs_depds = depds1 ++ depds2, + hs_ruleds = rulds1 ++ rulds2 } +\end{code} + +\begin{code} +instance OutputableBndr name => Outputable (HsDecl name) where + ppr (TyClD dcl) = ppr dcl + ppr (ValD binds) = ppr binds + ppr (DefD def) = ppr def + ppr (InstD inst) = ppr inst + ppr (ForD fd) = ppr fd + ppr (SigD sd) = ppr sd + ppr (RuleD rd) = ppr rd + ppr (DeprecD dd) = ppr dd + ppr (SpliceD dd) = ppr dd + +instance OutputableBndr name => Outputable (HsGroup name) where + ppr (HsGroup { hs_valds = val_decls, + hs_tyclds = tycl_decls, + hs_instds = inst_decls, + hs_fixds = fix_decls, + hs_depds = deprec_decls, + hs_fords = foreign_decls, + hs_defds = default_decls, + hs_ruleds = rule_decls }) + = vcat [ppr_ds fix_decls, ppr_ds default_decls, + ppr_ds deprec_decls, ppr_ds rule_decls, + ppr val_decls, + ppr_ds tycl_decls, ppr_ds inst_decls, + ppr_ds foreign_decls] + where + ppr_ds [] = empty + ppr_ds ds = text "" $$ vcat (map ppr ds) + +data SpliceDecl id = SpliceDecl (Located (HsExpr id)) -- Top level splice + +instance OutputableBndr name => Outputable (SpliceDecl name) where + ppr (SpliceDecl e) = ptext SLIT("$") <> parens (pprExpr (unLoc e)) +\end{code} + + +%************************************************************************ +%* * +\subsection[TyDecl]{@data@, @newtype@ or @type@ (synonym) type declaration} +%* * +%************************************************************************ + + -------------------------------- + THE NAMING STORY + -------------------------------- + +Here is the story about the implicit names that go with type, class, +and instance decls. It's a bit tricky, so pay attention! + +"Implicit" (or "system") binders +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + Each data type decl defines + a worker name for each constructor + to-T and from-T convertors + Each class decl defines + a tycon for the class + a data constructor for that tycon + the worker for that constructor + a selector for each superclass + +All have occurrence names that are derived uniquely from their parent +declaration. + +None of these get separate definitions in an interface file; they are +fully defined by the data or class decl. But they may *occur* in +interface files, of course. Any such occurrence must haul in the +relevant type or class decl. + +Plan of attack: + - Ensure they "point to" the parent data/class decl + when loading that decl from an interface file + (See RnHiFiles.getSysBinders) + + - When typechecking the decl, we build the implicit TyCons and Ids. + When doing so we look them up in the name cache (RnEnv.lookupSysName), + to ensure correct module and provenance is set + +These are the two places that we have to conjure up the magic derived +names. (The actual magic is in OccName.mkWorkerOcc, etc.) + +Default methods +~~~~~~~~~~~~~~~ + - Occurrence name is derived uniquely from the method name + E.g. $dmmax + + - If there is a default method name at all, it's recorded in + the ClassOpSig (in HsBinds), in the DefMeth field. + (DefMeth is defined in Class.lhs) + +Source-code class decls and interface-code class decls are treated subtly +differently, which has given me a great deal of confusion over the years. +Here's the deal. (We distinguish the two cases because source-code decls +have (Just binds) in the tcdMeths field, whereas interface decls have Nothing. + +In *source-code* class declarations: + + - When parsing, every ClassOpSig gets a DefMeth with a suitable RdrName + This is done by RdrHsSyn.mkClassOpSigDM + + - The renamer renames it to a Name + + - During typechecking, we generate a binding for each $dm for + which there's a programmer-supplied default method: + class Foo a where + op1 :: <type> + op2 :: <type> + op1 = ... + We generate a binding for $dmop1 but not for $dmop2. + The Class for Foo has a NoDefMeth for op2 and a DefMeth for op1. + The Name for $dmop2 is simply discarded. + +In *interface-file* class declarations: + - When parsing, we see if there's an explicit programmer-supplied default method + because there's an '=' sign to indicate it: + class Foo a where + op1 = :: <type> -- NB the '=' + op2 :: <type> + We use this info to generate a DefMeth with a suitable RdrName for op1, + and a NoDefMeth for op2 + - The interface file has a separate definition for $dmop1, with unfolding etc. + - The renamer renames it to a Name. + - The renamer treats $dmop1 as a free variable of the declaration, so that + the binding for $dmop1 will be sucked in. (See RnHsSyn.tyClDeclFVs) + This doesn't happen for source code class decls, because they *bind* the default method. + +Dictionary functions +~~~~~~~~~~~~~~~~~~~~ +Each instance declaration gives rise to one dictionary function binding. + +The type checker makes up new source-code instance declarations +(e.g. from 'deriving' or generic default methods --- see +TcInstDcls.tcInstDecls1). So we can't generate the names for +dictionary functions in advance (we don't know how many we need). + +On the other hand for interface-file instance declarations, the decl +specifies the name of the dictionary function, and it has a binding elsewhere +in the interface file: + instance {Eq Int} = dEqInt + dEqInt :: {Eq Int} <pragma info> + +So again we treat source code and interface file code slightly differently. + +Source code: + - Source code instance decls have a Nothing in the (Maybe name) field + (see data InstDecl below) + + - The typechecker makes up a Local name for the dict fun for any source-code + instance decl, whether it comes from a source-code instance decl, or whether + the instance decl is derived from some other construct (e.g. 'deriving'). + + - The occurrence name it chooses is derived from the instance decl (just for + documentation really) --- e.g. dNumInt. Two dict funs may share a common + occurrence name, but will have different uniques. E.g. + instance Foo [Int] where ... + instance Foo [Bool] where ... + These might both be dFooList + + - The CoreTidy phase externalises the name, and ensures the occurrence name is + unique (this isn't special to dict funs). So we'd get dFooList and dFooList1. + + - We can take this relaxed approach (changing the occurrence name later) + because dict fun Ids are not captured in a TyCon or Class (unlike default + methods, say). Instead, they are kept separately in the InstEnv. This + makes it easy to adjust them after compiling a module. (Once we've finished + compiling that module, they don't change any more.) + + +Interface file code: + - The instance decl gives the dict fun name, so the InstDecl has a (Just name) + in the (Maybe name) field. + + - RnHsSyn.instDeclFVs treats the dict fun name as free in the decl, so that we + suck in the dfun binding + + +\begin{code} +-- TyClDecls are precisely the kind of declarations that can +-- appear in interface files; or (internally) in GHC's interface +-- for a module. That's why (despite the misnomer) IfaceSig and ForeignType +-- are both in TyClDecl + +type LTyClDecl name = Located (TyClDecl name) + +data TyClDecl name + = ForeignType { + tcdLName :: Located name, + tcdExtName :: Maybe FastString, + tcdFoType :: FoType + } + + | TyData { tcdND :: NewOrData, + tcdCtxt :: LHsContext name, -- Context + tcdLName :: Located name, -- Type constructor + tcdTyVars :: [LHsTyVarBndr name], -- Type variables + tcdKindSig :: Maybe Kind, -- Optional kind sig; + -- (only for the 'where' form) + + tcdCons :: [LConDecl name], -- Data constructors + -- For data T a = T1 | T2 a the LConDecls all have ResTyH98 + -- For data T a where { T1 :: T a } the LConDecls all have ResTyGADT + + tcdDerivs :: Maybe [LHsType name] + -- Derivings; Nothing => not specified + -- Just [] => derive exactly what is asked + -- These "types" must be of form + -- forall ab. C ty1 ty2 + -- Typically the foralls and ty args are empty, but they + -- are non-empty for the newtype-deriving case + } + + | TySynonym { tcdLName :: Located name, -- type constructor + tcdTyVars :: [LHsTyVarBndr name], -- type variables + tcdSynRhs :: LHsType name -- synonym expansion + } + + | ClassDecl { tcdCtxt :: LHsContext name, -- Context... + tcdLName :: Located name, -- Name of the class + tcdTyVars :: [LHsTyVarBndr name], -- Class type variables + tcdFDs :: [Located (FunDep name)], -- Functional deps + tcdSigs :: [LSig name], -- Methods' signatures + tcdMeths :: LHsBinds name -- Default methods + } + +data NewOrData + = NewType -- "newtype Blah ..." + | DataType -- "data Blah ..." + deriving( Eq ) -- Needed because Demand derives Eq +\end{code} + +Simple classifiers + +\begin{code} +isDataDecl, isSynDecl, isClassDecl :: TyClDecl name -> Bool + +isSynDecl (TySynonym {}) = True +isSynDecl other = False + +isDataDecl (TyData {}) = True +isDataDecl other = False + +isClassDecl (ClassDecl {}) = True +isClassDecl other = False +\end{code} + +Dealing with names + +\begin{code} +tcdName :: TyClDecl name -> name +tcdName decl = unLoc (tcdLName decl) + +tyClDeclNames :: Eq name => TyClDecl name -> [Located name] +-- Returns all the *binding* names of the decl, along with their SrcLocs +-- The first one is guaranteed to be the name of the decl +-- For record fields, the first one counts as the SrcLoc +-- We use the equality to filter out duplicate field names + +tyClDeclNames (TySynonym {tcdLName = name}) = [name] +tyClDeclNames (ForeignType {tcdLName = name}) = [name] + +tyClDeclNames (ClassDecl {tcdLName = cls_name, tcdSigs = sigs}) + = cls_name : [n | L _ (TypeSig n _) <- sigs] + +tyClDeclNames (TyData {tcdLName = tc_name, tcdCons = cons}) + = tc_name : conDeclsNames (map unLoc cons) + +tyClDeclTyVars (TySynonym {tcdTyVars = tvs}) = tvs +tyClDeclTyVars (TyData {tcdTyVars = tvs}) = tvs +tyClDeclTyVars (ClassDecl {tcdTyVars = tvs}) = tvs +tyClDeclTyVars (ForeignType {}) = [] +\end{code} + +\begin{code} +countTyClDecls :: [TyClDecl name] -> (Int, Int, Int, Int) + -- class, data, newtype, synonym decls +countTyClDecls decls + = (count isClassDecl decls, + count isSynDecl decls, + count isDataTy decls, + count isNewTy decls) + where + isDataTy TyData{tcdND=DataType} = True + isDataTy _ = False + + isNewTy TyData{tcdND=NewType} = True + isNewTy _ = False +\end{code} + +\begin{code} +instance OutputableBndr name + => Outputable (TyClDecl name) where + + ppr (ForeignType {tcdLName = ltycon}) + = hsep [ptext SLIT("foreign import type dotnet"), ppr ltycon] + + ppr (TySynonym {tcdLName = ltycon, tcdTyVars = tyvars, tcdSynRhs = mono_ty}) + = hang (ptext SLIT("type") <+> pp_decl_head [] ltycon tyvars <+> equals) + 4 (ppr mono_ty) + + ppr (TyData {tcdND = new_or_data, tcdCtxt = context, tcdLName = ltycon, + tcdTyVars = tyvars, tcdKindSig = mb_sig, tcdCons = condecls, + tcdDerivs = derivings}) + = pp_tydecl (ppr new_or_data <+> pp_decl_head (unLoc context) ltycon tyvars <+> ppr_sig mb_sig) + (pp_condecls condecls) + derivings + where + ppr_sig Nothing = empty + ppr_sig (Just kind) = dcolon <+> pprKind kind + + ppr (ClassDecl {tcdCtxt = context, tcdLName = lclas, tcdTyVars = tyvars, tcdFDs = fds, + tcdSigs = sigs, tcdMeths = methods}) + | null sigs -- No "where" part + = top_matter + + | otherwise -- Laid out + = sep [hsep [top_matter, ptext SLIT("where {")], + nest 4 (sep [sep (map ppr_sig sigs), ppr methods, char '}'])] + where + top_matter = ptext SLIT("class") <+> pp_decl_head (unLoc context) lclas tyvars <+> pprFundeps (map unLoc fds) + ppr_sig sig = ppr sig <> semi + +pp_decl_head :: OutputableBndr name + => HsContext name + -> Located name + -> [LHsTyVarBndr name] + -> SDoc +pp_decl_head context thing tyvars + = hsep [pprHsContext context, ppr thing, interppSP tyvars] +pp_condecls cs@(L _ ConDecl{ con_res = ResTyGADT _ } : _) -- In GADT syntax + = hang (ptext SLIT("where")) 2 (vcat (map ppr cs)) +pp_condecls cs -- In H98 syntax + = equals <+> sep (punctuate (ptext SLIT(" |")) (map ppr cs)) + +pp_tydecl pp_head pp_decl_rhs derivings + = hang pp_head 4 (sep [ + pp_decl_rhs, + case derivings of + Nothing -> empty + Just ds -> hsep [ptext SLIT("deriving"), parens (interpp'SP ds)] + ]) + +instance Outputable NewOrData where + ppr NewType = ptext SLIT("newtype") + ppr DataType = ptext SLIT("data") +\end{code} + + +%************************************************************************ +%* * +\subsection[ConDecl]{A data-constructor declaration} +%* * +%************************************************************************ + +\begin{code} +type LConDecl name = Located (ConDecl name) + +-- data T b = forall a. Eq a => MkT a b +-- MkT :: forall b a. Eq a => MkT a b + +-- data T b where +-- MkT1 :: Int -> T Int + +-- data T = Int `MkT` Int +-- | MkT2 + +-- data T a where +-- Int `MkT` Int :: T Int + +data ConDecl name + = ConDecl + { con_name :: Located name -- Constructor name; this is used for the + -- DataCon itself, and for the user-callable wrapper Id + + , con_explicit :: HsExplicitForAll -- Is there an user-written forall? (cf. HStypes.HsForAllTy) + + , con_qvars :: [LHsTyVarBndr name] -- ResTyH98: the constructor's existential type variables + -- ResTyGADT: all the constructor's quantified type variables + + , con_cxt :: LHsContext name -- The context. This *does not* include the + -- "stupid theta" which lives only in the TyData decl + + , con_details :: HsConDetails name (LBangType name) -- The main payload + + , con_res :: ResType name -- Result type of the constructor + } + +data ResType name + = ResTyH98 -- Constructor was declared using Haskell 98 syntax + | ResTyGADT (LHsType name) -- Constructor was declared using GADT-style syntax, + -- and here is its result type +\end{code} + +\begin{code} +conDeclsNames :: Eq name => [ConDecl name] -> [Located name] + -- See tyClDeclNames for what this does + -- The function is boringly complicated because of the records + -- And since we only have equality, we have to be a little careful +conDeclsNames cons + = snd (foldl do_one ([], []) cons) + where + do_one (flds_seen, acc) (ConDecl { con_name = lname, con_details = RecCon flds }) + = (map unLoc new_flds ++ flds_seen, lname : [f | f <- new_flds] ++ acc) + where + new_flds = [ f | (f,_) <- flds, not (unLoc f `elem` flds_seen) ] + + do_one (flds_seen, acc) c + = (flds_seen, (con_name c):acc) + +conDetailsTys details = map getBangType (hsConArgs details) +\end{code} + + +\begin{code} +instance (OutputableBndr name) => Outputable (ConDecl name) where + ppr = pprConDecl + +pprConDecl (ConDecl con expl tvs cxt details ResTyH98) + = sep [pprHsForAll expl tvs cxt, ppr_details con details] + where + ppr_details con (InfixCon t1 t2) = hsep [ppr t1, pprHsVar con, ppr t2] + ppr_details con (PrefixCon tys) = hsep (pprHsVar con : map ppr tys) + ppr_details con (RecCon fields) = ppr con <+> ppr_fields fields + +pprConDecl (ConDecl con expl tvs cxt details (ResTyGADT res_ty)) + = sep [pprHsForAll expl tvs cxt, ppr con <+> ppr_details details] + where + ppr_details (PrefixCon arg_tys) = dcolon <+> ppr (foldr mk_fun_ty res_ty arg_tys) + ppr_details (RecCon fields) = ppr fields <+> dcolon <+> ppr res_ty + + mk_fun_ty a b = noLoc (HsFunTy a b) + +ppr_fields fields = braces (sep (punctuate comma (map ppr_field fields))) +ppr_field (n, ty) = ppr n <+> dcolon <+> ppr ty +\end{code} + +%************************************************************************ +%* * +\subsection[InstDecl]{An instance declaration +%* * +%************************************************************************ + +\begin{code} +type LInstDecl name = Located (InstDecl name) + +data InstDecl name + = InstDecl (LHsType name) -- Context => Class Instance-type + -- Using a polytype means that the renamer conveniently + -- figures out the quantified type variables for us. + (LHsBinds name) + [LSig name] -- User-supplied pragmatic info + +instance (OutputableBndr name) => Outputable (InstDecl name) where + + ppr (InstDecl inst_ty binds uprags) + = vcat [hsep [ptext SLIT("instance"), ppr inst_ty, ptext SLIT("where")], + nest 4 (ppr uprags), + nest 4 (pprLHsBinds binds) ] +\end{code} + +%************************************************************************ +%* * +\subsection[DefaultDecl]{A @default@ declaration} +%* * +%************************************************************************ + +There can only be one default declaration per module, but it is hard +for the parser to check that; we pass them all through in the abstract +syntax, and that restriction must be checked in the front end. + +\begin{code} +type LDefaultDecl name = Located (DefaultDecl name) + +data DefaultDecl name + = DefaultDecl [LHsType name] + +instance (OutputableBndr name) + => Outputable (DefaultDecl name) where + + ppr (DefaultDecl tys) + = ptext SLIT("default") <+> parens (interpp'SP tys) +\end{code} + +%************************************************************************ +%* * +\subsection{Foreign function interface declaration} +%* * +%************************************************************************ + +\begin{code} + +-- foreign declarations are distinguished as to whether they define or use a +-- Haskell name +-- +-- * the Boolean value indicates whether the pre-standard deprecated syntax +-- has been used +-- +type LForeignDecl name = Located (ForeignDecl name) + +data ForeignDecl name + = ForeignImport (Located name) (LHsType name) ForeignImport Bool -- defines name + | ForeignExport (Located name) (LHsType name) ForeignExport Bool -- uses name + +-- specification of an imported external entity in dependence on the calling +-- convention +-- +data ForeignImport = -- import of a C entity + -- + -- * the two strings specifying a header file or library + -- may be empty, which indicates the absence of a + -- header or object specification (both are not used + -- in the case of `CWrapper' and when `CFunction' + -- has a dynamic target) + -- + -- * the calling convention is irrelevant for code + -- generation in the case of `CLabel', but is needed + -- for pretty printing + -- + -- * `Safety' is irrelevant for `CLabel' and `CWrapper' + -- + CImport CCallConv -- ccall or stdcall + Safety -- safe or unsafe + FastString -- name of C header + FastString -- name of library object + CImportSpec -- details of the C entity + + -- import of a .NET function + -- + | DNImport DNCallSpec + +-- details of an external C entity +-- +data CImportSpec = CLabel CLabelString -- import address of a C label + | CFunction CCallTarget -- static or dynamic function + | CWrapper -- wrapper to expose closures + -- (former f.e.d.) + +-- specification of an externally exported entity in dependence on the calling +-- convention +-- +data ForeignExport = CExport CExportSpec -- contains the calling convention + | DNExport -- presently unused + +-- abstract type imported from .NET +-- +data FoType = DNType -- In due course we'll add subtype stuff + deriving (Eq) -- Used for equality instance for TyClDecl + + +-- pretty printing of foreign declarations +-- + +instance OutputableBndr name => Outputable (ForeignDecl name) where + ppr (ForeignImport n ty fimport _) = + ptext SLIT("foreign import") <+> ppr fimport <+> + ppr n <+> dcolon <+> ppr ty + ppr (ForeignExport n ty fexport _) = + ptext SLIT("foreign export") <+> ppr fexport <+> + ppr n <+> dcolon <+> ppr ty + +instance Outputable ForeignImport where + ppr (DNImport spec) = + ptext SLIT("dotnet") <+> ppr spec + ppr (CImport cconv safety header lib spec) = + ppr cconv <+> ppr safety <+> + char '"' <> pprCEntity header lib spec <> char '"' + where + pprCEntity header lib (CLabel lbl) = + ptext SLIT("static") <+> ftext header <+> char '&' <> + pprLib lib <> ppr lbl + pprCEntity header lib (CFunction (StaticTarget lbl)) = + ptext SLIT("static") <+> ftext header <+> char '&' <> + pprLib lib <> ppr lbl + pprCEntity header lib (CFunction (DynamicTarget)) = + ptext SLIT("dynamic") + pprCEntity _ _ (CWrapper) = ptext SLIT("wrapper") + -- + pprLib lib | nullFS lib = empty + | otherwise = char '[' <> ppr lib <> char ']' + +instance Outputable ForeignExport where + ppr (CExport (CExportStatic lbl cconv)) = + ppr cconv <+> char '"' <> ppr lbl <> char '"' + ppr (DNExport ) = + ptext SLIT("dotnet") <+> ptext SLIT("\"<unused>\"") + +instance Outputable FoType where + ppr DNType = ptext SLIT("type dotnet") +\end{code} + + +%************************************************************************ +%* * +\subsection{Transformation rules} +%* * +%************************************************************************ + +\begin{code} +type LRuleDecl name = Located (RuleDecl name) + +data RuleDecl name + = HsRule -- Source rule + RuleName -- Rule name + Activation + [RuleBndr name] -- Forall'd vars; after typechecking this includes tyvars + (Located (HsExpr name)) -- LHS + NameSet -- Free-vars from the LHS + (Located (HsExpr name)) -- RHS + NameSet -- Free-vars from the RHS + +data RuleBndr name + = RuleBndr (Located name) + | RuleBndrSig (Located name) (LHsType name) + +collectRuleBndrSigTys :: [RuleBndr name] -> [LHsType name] +collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ ty <- bndrs] + +instance OutputableBndr name => Outputable (RuleDecl name) where + ppr (HsRule name act ns lhs fv_lhs rhs fv_rhs) + = sep [text "{-# RULES" <+> doubleQuotes (ftext name) <+> ppr act, + nest 4 (pp_forall <+> pprExpr (unLoc lhs)), + nest 4 (equals <+> pprExpr (unLoc rhs) <+> text "#-}") ] + where + pp_forall | null ns = empty + | otherwise = text "forall" <+> fsep (map ppr ns) <> dot + +instance OutputableBndr name => Outputable (RuleBndr name) where + ppr (RuleBndr name) = ppr name + ppr (RuleBndrSig name ty) = ppr name <> dcolon <> ppr ty +\end{code} + + +%************************************************************************ +%* * +\subsection[DeprecDecl]{Deprecations} +%* * +%************************************************************************ + +We use exported entities for things to deprecate. + +\begin{code} +type LDeprecDecl name = Located (DeprecDecl name) + +data DeprecDecl name = Deprecation name DeprecTxt + +instance OutputableBndr name => Outputable (DeprecDecl name) where + ppr (Deprecation thing txt) + = hsep [text "{-# DEPRECATED", ppr thing, doubleQuotes (ppr txt), text "#-}"] +\end{code} diff --git a/compiler/hsSyn/HsExpr.hi-boot-5 b/compiler/hsSyn/HsExpr.hi-boot-5 new file mode 100644 index 0000000000..05e2eb5394 --- /dev/null +++ b/compiler/hsSyn/HsExpr.hi-boot-5 @@ -0,0 +1,14 @@ +__interface HsExpr 1 0 where +__export HsExpr HsExpr pprExpr Match GRHSs LHsExpr LMatch pprPatBind pprFunBind ; + +1 data HsExpr i ; +1 data Match a ; +1 data GRHSs a ; + +1 type LHsExpr a = SrcLoc.Located (HsExpr a) ; +1 type LMatch a = SrcLoc.Located (Match a) ; + +1 pprExpr :: __forall [i] {Outputable.OutputableBndr i} => HsExpr.HsExpr i -> Outputable.SDoc ; +1 pprPatBind :: __forall [i] {Outputable.OutputableBndr i} => HsPat.LPat i -> HsExpr.GRHSs i -> Outputable.SDoc ; +1 pprFunBind :: __forall [i] {Outputable.OutputableBndr i} => i -> [HsExpr.LMatch i] -> Outputable.SDoc ; + diff --git a/compiler/hsSyn/HsExpr.hi-boot-6 b/compiler/hsSyn/HsExpr.hi-boot-6 new file mode 100644 index 0000000000..40e18ef971 --- /dev/null +++ b/compiler/hsSyn/HsExpr.hi-boot-6 @@ -0,0 +1,22 @@ +module HsExpr where + +data HsExpr i +data HsSplice i +data MatchGroup a +data GRHSs a + +type LHsExpr a = SrcLoc.Located (HsExpr a) +type SyntaxExpr a = HsExpr a +type PostTcExpr = HsExpr Var.Id + +pprExpr :: (Outputable.OutputableBndr i) => + HsExpr.HsExpr i -> Outputable.SDoc + +pprSplice :: (Outputable.OutputableBndr i) => + HsExpr.HsSplice i -> Outputable.SDoc + +pprPatBind :: (Outputable.OutputableBndr b, Outputable.OutputableBndr i) => + HsPat.LPat b -> HsExpr.GRHSs i -> Outputable.SDoc + +pprFunBind :: (Outputable.OutputableBndr i) => + i -> HsExpr.MatchGroup i -> Outputable.SDoc diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs new file mode 100644 index 0000000000..dbdd24c3c5 --- /dev/null +++ b/compiler/hsSyn/HsExpr.lhs @@ -0,0 +1,975 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +% +\section[HsExpr]{Abstract Haskell syntax: expressions} + +\begin{code} +module HsExpr where + +#include "HsVersions.h" + +-- friends: +import HsDecls ( HsGroup ) +import HsPat ( LPat ) +import HsLit ( HsLit(..), HsOverLit ) +import HsTypes ( LHsType, PostTcType ) +import HsImpExp ( isOperator, pprHsVar ) +import HsBinds ( HsLocalBinds, DictBinds, ExprCoFn, isEmptyLocalBinds ) + +-- others: +import Type ( Type, pprParendType ) +import Var ( TyVar, Id ) +import Name ( Name ) +import BasicTypes ( IPName, Boxity, tupleParens, Arity, Fixity(..) ) +import SrcLoc ( Located(..), unLoc ) +import Outputable +import FastString +\end{code} + + +%************************************************************************ +%* * +\subsection{Expressions proper} +%* * +%************************************************************************ + +\begin{code} +type LHsExpr id = Located (HsExpr id) + +------------------------- +-- PostTcExpr is an evidence expression attached to the +-- syntax tree by the type checker (c.f. postTcType) +-- We use a PostTcTable where there are a bunch of pieces of +-- evidence, more than is convenient to keep individually +type PostTcExpr = HsExpr Id +type PostTcTable = [(Name, Id)] + +noPostTcExpr :: PostTcExpr +noPostTcExpr = HsLit (HsString FSLIT("noPostTcExpr")) + +noPostTcTable :: PostTcTable +noPostTcTable = [] + +------------------------- +-- SyntaxExpr is like PostTcExpr, but it's filled in a little earlier, +-- by the renamer. It's used for rebindable syntax. +-- E.g. (>>=) is filled in before the renamer by the appropriate Name +-- for (>>=), and then instantiated by the type checker with its +-- type args tec + +type SyntaxExpr id = HsExpr id + +noSyntaxExpr :: SyntaxExpr id -- Before renaming, and sometimes after, + -- (if the syntax slot makes no sense) +noSyntaxExpr = HsLit (HsString FSLIT("noSyntaxExpr")) + + +type SyntaxTable id = [(Name, SyntaxExpr id)] +-- *** Currently used only for CmdTop (sigh) *** +-- * Before the renamer, this list is noSyntaxTable +-- +-- * After the renamer, it takes the form [(std_name, HsVar actual_name)] +-- For example, for the 'return' op of a monad +-- normal case: (GHC.Base.return, HsVar GHC.Base.return) +-- with rebindable syntax: (GHC.Base.return, return_22) +-- where return_22 is whatever "return" is in scope +-- +-- * After the type checker, it takes the form [(std_name, <expression>)] +-- where <expression> is the evidence for the method + +noSyntaxTable :: SyntaxTable id +noSyntaxTable = [] + + +------------------------- +data HsExpr id + = HsVar id -- variable + | HsIPVar (IPName id) -- implicit parameter + | HsOverLit (HsOverLit id) -- Overloaded literals + | HsLit HsLit -- Simple (non-overloaded) literals + + | HsLam (MatchGroup id) -- Currently always a single match + + | HsApp (LHsExpr id) -- Application + (LHsExpr id) + + -- Operator applications: + -- NB Bracketed ops such as (+) come out as Vars. + + -- NB We need an expr for the operator in an OpApp/Section since + -- the typechecker may need to apply the operator to a few types. + + | OpApp (LHsExpr id) -- left operand + (LHsExpr id) -- operator + Fixity -- Renamer adds fixity; bottom until then + (LHsExpr id) -- right operand + + | NegApp (LHsExpr id) -- negated expr + (SyntaxExpr id) -- Name of 'negate' + + | HsPar (LHsExpr id) -- parenthesised expr + + | SectionL (LHsExpr id) -- operand + (LHsExpr id) -- operator + | SectionR (LHsExpr id) -- operator + (LHsExpr id) -- operand + + | HsCase (LHsExpr id) + (MatchGroup id) + + | HsIf (LHsExpr id) -- predicate + (LHsExpr id) -- then part + (LHsExpr id) -- else part + + | HsLet (HsLocalBinds id) -- let(rec) + (LHsExpr id) + + | HsDo (HsStmtContext Name) -- The parameterisation is unimportant + -- because in this context we never use + -- the PatGuard or ParStmt variant + [LStmt id] -- "do":one or more stmts + (LHsExpr id) -- The body; the last expression in the 'do' + -- of [ body | ... ] in a list comp + PostTcType -- Type of the whole expression + + | ExplicitList -- syntactic list + PostTcType -- Gives type of components of list + [LHsExpr id] + + | ExplicitPArr -- syntactic parallel array: [:e1, ..., en:] + PostTcType -- type of elements of the parallel array + [LHsExpr id] + + | ExplicitTuple -- tuple + [LHsExpr id] + -- NB: Unit is ExplicitTuple [] + -- for tuples, we can get the types + -- direct from the components + Boxity + + + -- Record construction + | RecordCon (Located id) -- The constructor. After type checking + -- it's the dataConWrapId of the constructor + PostTcExpr -- Data con Id applied to type args + (HsRecordBinds id) + + -- Record update + | RecordUpd (LHsExpr id) + (HsRecordBinds id) + PostTcType -- Type of *input* record + PostTcType -- Type of *result* record (may differ from + -- type of input record) + + | ExprWithTySig -- e :: type + (LHsExpr id) + (LHsType id) + + | ExprWithTySigOut -- TRANSLATION + (LHsExpr id) + (LHsType Name) -- Retain the signature for round-tripping purposes + + | ArithSeq -- arithmetic sequence + PostTcExpr + (ArithSeqInfo id) + + | PArrSeq -- arith. sequence for parallel array + PostTcExpr -- [:e1..e2:] or [:e1, e2..e3:] + (ArithSeqInfo id) + + | HsSCC FastString -- "set cost centre" (_scc_) annotation + (LHsExpr id) -- expr whose cost is to be measured + + | HsCoreAnn FastString -- hdaume: core annotation + (LHsExpr id) + + ----------------------------------------------------------- + -- MetaHaskell Extensions + | HsBracket (HsBracket id) + + | HsBracketOut (HsBracket Name) -- Output of the type checker is the *original* + [PendingSplice] -- renamed expression, plus *typechecked* splices + -- to be pasted back in by the desugarer + + | HsSpliceE (HsSplice id) + + ----------------------------------------------------------- + -- Arrow notation extension + + | HsProc (LPat id) -- arrow abstraction, proc + (LHsCmdTop id) -- body of the abstraction + -- always has an empty stack + + --------------------------------------- + -- The following are commands, not expressions proper + + | HsArrApp -- Arrow tail, or arrow application (f -< arg) + (LHsExpr id) -- arrow expression, f + (LHsExpr id) -- input expression, arg + PostTcType -- type of the arrow expressions f, + -- of the form a t t', where arg :: t + HsArrAppType -- higher-order (-<<) or first-order (-<) + Bool -- True => right-to-left (f -< arg) + -- False => left-to-right (arg >- f) + + | HsArrForm -- Command formation, (| e cmd1 .. cmdn |) + (LHsExpr id) -- the operator + -- after type-checking, a type abstraction to be + -- applied to the type of the local environment tuple + (Maybe Fixity) -- fixity (filled in by the renamer), for forms that + -- were converted from OpApp's by the renamer + [LHsCmdTop id] -- argument commands +\end{code} + + +These constructors only appear temporarily in the parser. +The renamer translates them into the Right Thing. + +\begin{code} + | EWildPat -- wildcard + + | EAsPat (Located id) -- as pattern + (LHsExpr id) + + | ELazyPat (LHsExpr id) -- ~ pattern + + | HsType (LHsType id) -- Explicit type argument; e.g f {| Int |} x y +\end{code} + +Everything from here on appears only in typechecker output. + +\begin{code} + | TyLam -- TRANSLATION + [TyVar] + (LHsExpr id) + | TyApp -- TRANSLATION + (LHsExpr id) -- generated by Spec + [Type] + + -- DictLam and DictApp are "inverses" + | DictLam + [id] + (LHsExpr id) + | DictApp + (LHsExpr id) + [id] + + | HsCoerce ExprCoFn -- TRANSLATION + (HsExpr id) + +type PendingSplice = (Name, LHsExpr Id) -- Typechecked splices, waiting to be + -- pasted back in by the desugarer +\end{code} + +A @Dictionary@, unless of length 0 or 1, becomes a tuple. A +@ClassDictLam dictvars methods expr@ is, therefore: +\begin{verbatim} +\ x -> case x of ( dictvars-and-methods-tuple ) -> expr +\end{verbatim} + +\begin{code} +instance OutputableBndr id => Outputable (HsExpr id) where + ppr expr = pprExpr expr +\end{code} + +\begin{code} +pprExpr :: OutputableBndr id => HsExpr id -> SDoc + +pprExpr e = pprDeeper (ppr_expr e) + +pprBinds :: OutputableBndr id => HsLocalBinds id -> SDoc +pprBinds b = pprDeeper (ppr b) + +ppr_lexpr :: OutputableBndr id => LHsExpr id -> SDoc +ppr_lexpr e = ppr_expr (unLoc e) + +ppr_expr (HsVar v) = pprHsVar v +ppr_expr (HsIPVar v) = ppr v +ppr_expr (HsLit lit) = ppr lit +ppr_expr (HsOverLit lit) = ppr lit + +ppr_expr (HsApp e1 e2) + = let (fun, args) = collect_args e1 [e2] in + (ppr_lexpr fun) <+> (sep (map pprParendExpr args)) + where + collect_args (L _ (HsApp fun arg)) args = collect_args fun (arg:args) + collect_args fun args = (fun, args) + +ppr_expr (OpApp e1 op fixity e2) + = case unLoc op of + HsVar v -> pp_infixly v + _ -> pp_prefixly + where + pp_e1 = pprParendExpr e1 -- Add parens to make precedence clear + pp_e2 = pprParendExpr e2 + + pp_prefixly + = hang (ppr op) 4 (sep [pp_e1, pp_e2]) + + pp_infixly v + = sep [pp_e1, hsep [pprInfix v, pp_e2]] + +ppr_expr (NegApp e _) = char '-' <+> pprParendExpr e + +ppr_expr (HsPar e) = parens (ppr_lexpr e) + +ppr_expr (SectionL expr op) + = case unLoc op of + HsVar v -> pp_infixly v + _ -> pp_prefixly + where + pp_expr = pprParendExpr expr + + pp_prefixly = hang (hsep [text " \\ x_ ->", ppr op]) + 4 (hsep [pp_expr, ptext SLIT("x_ )")]) + pp_infixly v = parens (sep [pp_expr, pprInfix v]) + +ppr_expr (SectionR op expr) + = case unLoc op of + HsVar v -> pp_infixly v + _ -> pp_prefixly + where + pp_expr = pprParendExpr expr + + pp_prefixly = hang (hsep [text "( \\ x_ ->", ppr op, ptext SLIT("x_")]) + 4 ((<>) pp_expr rparen) + pp_infixly v + = parens (sep [pprInfix v, pp_expr]) + +ppr_expr (HsLam matches) + = pprMatches LambdaExpr matches + +ppr_expr (HsCase expr matches) + = sep [ sep [ptext SLIT("case"), nest 4 (ppr expr), ptext SLIT("of")], + nest 2 (pprMatches CaseAlt matches) ] + +ppr_expr (HsIf e1 e2 e3) + = sep [hsep [ptext SLIT("if"), nest 2 (ppr e1), ptext SLIT("then")], + nest 4 (ppr e2), + ptext SLIT("else"), + nest 4 (ppr e3)] + +-- special case: let ... in let ... +ppr_expr (HsLet binds expr@(L _ (HsLet _ _))) + = sep [hang (ptext SLIT("let")) 2 (hsep [pprBinds binds, ptext SLIT("in")]), + ppr_lexpr expr] + +ppr_expr (HsLet binds expr) + = sep [hang (ptext SLIT("let")) 2 (pprBinds binds), + hang (ptext SLIT("in")) 2 (ppr expr)] + +ppr_expr (HsDo do_or_list_comp stmts body _) = pprDo do_or_list_comp stmts body + +ppr_expr (ExplicitList _ exprs) + = brackets (fsep (punctuate comma (map ppr_lexpr exprs))) + +ppr_expr (ExplicitPArr _ exprs) + = pa_brackets (fsep (punctuate comma (map ppr_lexpr exprs))) + +ppr_expr (ExplicitTuple exprs boxity) + = tupleParens boxity (sep (punctuate comma (map ppr_lexpr exprs))) + +ppr_expr (RecordCon con_id con_expr rbinds) + = pp_rbinds (ppr con_id) rbinds + +ppr_expr (RecordUpd aexp rbinds _ _) + = pp_rbinds (pprParendExpr aexp) rbinds + +ppr_expr (ExprWithTySig expr sig) + = hang (nest 2 (ppr_lexpr expr) <+> dcolon) + 4 (ppr sig) +ppr_expr (ExprWithTySigOut expr sig) + = hang (nest 2 (ppr_lexpr expr) <+> dcolon) + 4 (ppr sig) + +ppr_expr (ArithSeq expr info) = brackets (ppr info) +ppr_expr (PArrSeq expr info) = pa_brackets (ppr info) + +ppr_expr EWildPat = char '_' +ppr_expr (ELazyPat e) = char '~' <> pprParendExpr e +ppr_expr (EAsPat v e) = ppr v <> char '@' <> pprParendExpr e + +ppr_expr (HsSCC lbl expr) + = sep [ ptext SLIT("_scc_") <+> doubleQuotes (ftext lbl), pprParendExpr expr ] + +ppr_expr (TyLam tyvars expr) + = hang (hsep [ptext SLIT("/\\"), + hsep (map (pprBndr LambdaBind) tyvars), + ptext SLIT("->")]) + 4 (ppr_lexpr expr) + +ppr_expr (TyApp expr [ty]) + = hang (ppr_lexpr expr) 4 (pprParendType ty) + +ppr_expr (TyApp expr tys) + = hang (ppr_lexpr expr) + 4 (brackets (interpp'SP tys)) + +ppr_expr (DictLam dictvars expr) + = hang (hsep [ptext SLIT("\\{-dict-}"), + hsep (map (pprBndr LambdaBind) dictvars), + ptext SLIT("->")]) + 4 (ppr_lexpr expr) + +ppr_expr (DictApp expr [dname]) + = hang (ppr_lexpr expr) 4 (ppr dname) + +ppr_expr (DictApp expr dnames) + = hang (ppr_lexpr expr) + 4 (brackets (interpp'SP dnames)) + +ppr_expr (HsCoerce co_fn e) = ppr_expr e + +ppr_expr (HsType id) = ppr id + +ppr_expr (HsSpliceE s) = pprSplice s +ppr_expr (HsBracket b) = pprHsBracket b +ppr_expr (HsBracketOut e []) = ppr e +ppr_expr (HsBracketOut e ps) = ppr e $$ ptext SLIT("pending") <+> ppr ps + +ppr_expr (HsProc pat (L _ (HsCmdTop cmd _ _ _))) + = hsep [ptext SLIT("proc"), ppr pat, ptext SLIT("->"), ppr cmd] + +ppr_expr (HsArrApp arrow arg _ HsFirstOrderApp True) + = hsep [ppr_lexpr arrow, ptext SLIT("-<"), ppr_lexpr arg] +ppr_expr (HsArrApp arrow arg _ HsFirstOrderApp False) + = hsep [ppr_lexpr arg, ptext SLIT(">-"), ppr_lexpr arrow] +ppr_expr (HsArrApp arrow arg _ HsHigherOrderApp True) + = hsep [ppr_lexpr arrow, ptext SLIT("-<<"), ppr_lexpr arg] +ppr_expr (HsArrApp arrow arg _ HsHigherOrderApp False) + = hsep [ppr_lexpr arg, ptext SLIT(">>-"), ppr_lexpr arrow] + +ppr_expr (HsArrForm (L _ (HsVar v)) (Just _) [arg1, arg2]) + = sep [pprCmdArg (unLoc arg1), hsep [pprInfix v, pprCmdArg (unLoc arg2)]] +ppr_expr (HsArrForm op _ args) + = hang (ptext SLIT("(|") <> ppr_lexpr op) + 4 (sep (map (pprCmdArg.unLoc) args) <> ptext SLIT("|)")) + +pprCmdArg :: OutputableBndr id => HsCmdTop id -> SDoc +pprCmdArg (HsCmdTop cmd@(L _ (HsArrForm _ Nothing [])) _ _ _) + = ppr_lexpr cmd +pprCmdArg (HsCmdTop cmd _ _ _) + = parens (ppr_lexpr cmd) + +-- Put a var in backquotes if it's not an operator already +pprInfix :: Outputable name => name -> SDoc +pprInfix v | isOperator ppr_v = ppr_v + | otherwise = char '`' <> ppr_v <> char '`' + where + ppr_v = ppr v + +-- add parallel array brackets around a document +-- +pa_brackets :: SDoc -> SDoc +pa_brackets p = ptext SLIT("[:") <> p <> ptext SLIT(":]") +\end{code} + +Parenthesize unless very simple: +\begin{code} +pprParendExpr :: OutputableBndr id => LHsExpr id -> SDoc +pprParendExpr expr + = let + pp_as_was = ppr_lexpr expr + -- Using ppr_expr here avoids the call to 'deeper' + -- Not sure if that's always right. + in + case unLoc expr of + HsLit l -> ppr l + HsOverLit l -> ppr l + + HsVar _ -> pp_as_was + HsIPVar _ -> pp_as_was + ExplicitList _ _ -> pp_as_was + ExplicitPArr _ _ -> pp_as_was + ExplicitTuple _ _ -> pp_as_was + HsPar _ -> pp_as_was + HsBracket _ -> pp_as_was + HsBracketOut _ [] -> pp_as_was + + _ -> parens pp_as_was +\end{code} + +%************************************************************************ +%* * +\subsection{Commands (in arrow abstractions)} +%* * +%************************************************************************ + +We re-use HsExpr to represent these. + +\begin{code} +type HsCmd id = HsExpr id + +type LHsCmd id = LHsExpr id + +data HsArrAppType = HsHigherOrderApp | HsFirstOrderApp +\end{code} + +The legal constructors for commands are: + + = HsArrApp ... -- as above + + | HsArrForm ... -- as above + + | HsApp (HsCmd id) + (HsExpr id) + + | HsLam (Match id) -- kappa + + -- the renamer turns this one into HsArrForm + | OpApp (HsExpr id) -- left operand + (HsCmd id) -- operator + Fixity -- Renamer adds fixity; bottom until then + (HsCmd id) -- right operand + + | HsPar (HsCmd id) -- parenthesised command + + | HsCase (HsExpr id) + [Match id] -- bodies are HsCmd's + SrcLoc + + | HsIf (HsExpr id) -- predicate + (HsCmd id) -- then part + (HsCmd id) -- else part + SrcLoc + + | HsLet (HsLocalBinds id) -- let(rec) + (HsCmd id) + + | HsDo (HsStmtContext Name) -- The parameterisation is unimportant + -- because in this context we never use + -- the PatGuard or ParStmt variant + [Stmt id] -- HsExpr's are really HsCmd's + PostTcType -- Type of the whole expression + SrcLoc + +Top-level command, introducing a new arrow. +This may occur inside a proc (where the stack is empty) or as an +argument of a command-forming operator. + +\begin{code} +type LHsCmdTop id = Located (HsCmdTop id) + +data HsCmdTop id + = HsCmdTop (LHsCmd id) + [PostTcType] -- types of inputs on the command's stack + PostTcType -- return type of the command + (SyntaxTable id) + -- after type checking: + -- names used in the command's desugaring +\end{code} + +%************************************************************************ +%* * +\subsection{Record binds} +%* * +%************************************************************************ + +\begin{code} +type HsRecordBinds id = [(Located id, LHsExpr id)] + +recBindFields :: HsRecordBinds id -> [id] +recBindFields rbinds = [unLoc field | (field,_) <- rbinds] + +pp_rbinds :: OutputableBndr id => SDoc -> HsRecordBinds id -> SDoc +pp_rbinds thing rbinds + = hang thing + 4 (braces (sep (punctuate comma (map (pp_rbind) rbinds)))) + where + pp_rbind (v, e) = hsep [pprBndr LetBind (unLoc v), char '=', ppr e] +\end{code} + + + +%************************************************************************ +%* * +\subsection{@Match@, @GRHSs@, and @GRHS@ datatypes} +%* * +%************************************************************************ + +@Match@es are sets of pattern bindings and right hand sides for +functions, patterns or case branches. For example, if a function @g@ +is defined as: +\begin{verbatim} +g (x,y) = y +g ((x:ys),y) = y+1, +\end{verbatim} +then \tr{g} has two @Match@es: @(x,y) = y@ and @((x:ys),y) = y+1@. + +It is always the case that each element of an @[Match]@ list has the +same number of @pats@s inside it. This corresponds to saying that +a function defined by pattern matching must have the same number of +patterns in each equation. + +\begin{code} +data MatchGroup id + = MatchGroup + [LMatch id] -- The alternatives + PostTcType -- The type is the type of the entire group + -- t1 -> ... -> tn -> tr + -- where there are n patterns + +type LMatch id = Located (Match id) + +data Match id + = Match + [LPat id] -- The patterns + (Maybe (LHsType id)) -- A type signature for the result of the match + -- Nothing after typechecking + (GRHSs id) + +matchGroupArity :: MatchGroup id -> Arity +matchGroupArity (MatchGroup (match:matches) _) + = ASSERT( all ((== n_pats) . length . hsLMatchPats) matches ) + -- Assertion just checks that all the matches have the same number of pats + n_pats + where + n_pats = length (hsLMatchPats match) + +hsLMatchPats :: LMatch id -> [LPat id] +hsLMatchPats (L _ (Match pats _ _)) = pats + +-- GRHSs are used both for pattern bindings and for Matches +data GRHSs id + = GRHSs [LGRHS id] -- Guarded RHSs + (HsLocalBinds id) -- The where clause + +type LGRHS id = Located (GRHS id) + +data GRHS id = GRHS [LStmt id] -- Guards + (LHsExpr id) -- Right hand side +\end{code} + +We know the list must have at least one @Match@ in it. + +\begin{code} +pprMatches :: (OutputableBndr id) => HsMatchContext id -> MatchGroup id -> SDoc +pprMatches ctxt (MatchGroup matches _) = vcat (map (pprMatch ctxt) (map unLoc matches)) + +-- Exported to HsBinds, which can't see the defn of HsMatchContext +pprFunBind :: (OutputableBndr id) => id -> MatchGroup id -> SDoc +pprFunBind fun matches = pprMatches (FunRhs fun) matches + +-- Exported to HsBinds, which can't see the defn of HsMatchContext +pprPatBind :: (OutputableBndr bndr, OutputableBndr id) + => LPat bndr -> GRHSs id -> SDoc +pprPatBind pat grhss = sep [ppr pat, nest 4 (pprGRHSs PatBindRhs grhss)] + + +pprMatch :: OutputableBndr id => HsMatchContext id -> Match id -> SDoc +pprMatch ctxt (Match pats maybe_ty grhss) + = pp_name ctxt <+> sep [sep (map ppr pats), + ppr_maybe_ty, + nest 2 (pprGRHSs ctxt grhss)] + where + pp_name (FunRhs fun) = ppr fun -- Not pprBndr; the AbsBinds will + -- have printed the signature + pp_name LambdaExpr = char '\\' + pp_name other = empty + + ppr_maybe_ty = case maybe_ty of + Just ty -> dcolon <+> ppr ty + Nothing -> empty + + +pprGRHSs :: OutputableBndr id => HsMatchContext id -> GRHSs id -> SDoc +pprGRHSs ctxt (GRHSs grhss binds) + = vcat (map (pprGRHS ctxt . unLoc) grhss) + $$ + (if isEmptyLocalBinds binds then empty + else text "where" $$ nest 4 (pprBinds binds)) + +pprGRHS :: OutputableBndr id => HsMatchContext id -> GRHS id -> SDoc + +pprGRHS ctxt (GRHS [] expr) + = pp_rhs ctxt expr + +pprGRHS ctxt (GRHS guards expr) + = sep [char '|' <+> interpp'SP guards, pp_rhs ctxt expr] + +pp_rhs ctxt rhs = matchSeparator ctxt <+> pprDeeper (ppr rhs) +\end{code} + +%************************************************************************ +%* * +\subsection{Do stmts and list comprehensions} +%* * +%************************************************************************ + +\begin{code} +type LStmt id = Located (Stmt id) + +-- The SyntaxExprs in here are used *only* for do-notation, which +-- has rebindable syntax. Otherwise they are unused. +data Stmt id + = BindStmt (LPat id) + (LHsExpr id) + (SyntaxExpr id) -- The (>>=) operator + (SyntaxExpr id) -- The fail operator + -- The fail operator is noSyntaxExpr + -- if the pattern match can't fail + + | ExprStmt (LHsExpr id) + (SyntaxExpr id) -- The (>>) operator + PostTcType -- Element type of the RHS (used for arrows) + + | LetStmt (HsLocalBinds id) + + -- ParStmts only occur in a list comprehension + | ParStmt [([LStmt id], [id])] -- After renaming, the ids are the binders + -- bound by the stmts and used subsequently + + -- Recursive statement (see Note [RecStmt] below) + | RecStmt [LStmt id] + --- The next two fields are only valid after renaming + [id] -- The ids are a subset of the variables bound by the stmts + -- that are used in stmts that follow the RecStmt + + [id] -- Ditto, but these variables are the "recursive" ones, that + -- are used before they are bound in the stmts of the RecStmt + -- From a type-checking point of view, these ones have to be monomorphic + + --- These fields are only valid after typechecking + [PostTcExpr] -- These expressions correspond + -- 1-to-1 with the "recursive" [id], and are the expresions that + -- should be returned by the recursion. They may not quite be the + -- Ids themselves, because the Id may be *polymorphic*, but + -- the returned thing has to be *monomorphic*. + (DictBinds id) -- Method bindings of Ids bound by the RecStmt, + -- and used afterwards +\end{code} + +ExprStmts are a bit tricky, because what they mean +depends on the context. Consider the following contexts: + + A do expression of type (m res_ty) + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + * ExprStmt E any_ty: do { ....; E; ... } + E :: m any_ty + Translation: E >> ... + + A list comprehensions of type [elt_ty] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + * ExprStmt E Bool: [ .. | .... E ] + [ .. | ..., E, ... ] + [ .. | .... | ..., E | ... ] + E :: Bool + Translation: if E then fail else ... + + A guard list, guarding a RHS of type rhs_ty + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + * ExprStmt E Bool: f x | ..., E, ... = ...rhs... + E :: Bool + Translation: if E then fail else ... + +Array comprehensions are handled like list comprehensions -=chak + +Note [RecStmt] +~~~~~~~~~~~~~~ +Example: + HsDo [ BindStmt x ex + + , RecStmt [a::forall a. a -> a, b] + [a::Int -> Int, c] + [ BindStmt b (return x) + , LetStmt a = ea + , BindStmt c ec ] + + , return (a b) ] + +Here, the RecStmt binds a,b,c; but + - Only a,b are used in the stmts *following* the RecStmt, + This 'a' is *polymorphic' + - Only a,c are used in the stmts *inside* the RecStmt + *before* their bindings + This 'a' is monomorphic + +Nota Bene: the two a's have different types, even though they +have the same Name. + + +\begin{code} +instance OutputableBndr id => Outputable (Stmt id) where + ppr stmt = pprStmt stmt + +pprStmt (BindStmt pat expr _ _) = hsep [ppr pat, ptext SLIT("<-"), ppr expr] +pprStmt (LetStmt binds) = hsep [ptext SLIT("let"), pprBinds binds] +pprStmt (ExprStmt expr _ _) = ppr expr +pprStmt (ParStmt stmtss) = hsep (map (\stmts -> ptext SLIT("| ") <> ppr stmts) stmtss) +pprStmt (RecStmt segment _ _ _ _) = ptext SLIT("rec") <+> braces (vcat (map ppr segment)) + +pprDo :: OutputableBndr id => HsStmtContext any -> [LStmt id] -> LHsExpr id -> SDoc +pprDo DoExpr stmts body = hang (ptext SLIT("do")) 2 (vcat (map ppr stmts) $$ ppr body) +pprDo (MDoExpr _) stmts body = hang (ptext SLIT("mdo")) 3 (vcat (map ppr stmts) $$ ppr body) +pprDo ListComp stmts body = pprComp brackets stmts body +pprDo PArrComp stmts body = pprComp pa_brackets stmts body + +pprComp :: OutputableBndr id => (SDoc -> SDoc) -> [LStmt id] -> LHsExpr id -> SDoc +pprComp brack quals body + = brack $ + hang (ppr body <+> char '|') + 4 (interpp'SP quals) +\end{code} + +%************************************************************************ +%* * + Template Haskell quotation brackets +%* * +%************************************************************************ + +\begin{code} +data HsSplice id = HsSplice -- $z or $(f 4) + id -- The id is just a unique name to + (LHsExpr id) -- identify this splice point + +instance OutputableBndr id => Outputable (HsSplice id) where + ppr = pprSplice + +pprSplice :: OutputableBndr id => HsSplice id -> SDoc +pprSplice (HsSplice n e) = char '$' <> brackets (ppr n) <> pprParendExpr e + + +data HsBracket id = ExpBr (LHsExpr id) -- [| expr |] + | PatBr (LPat id) -- [p| pat |] + | DecBr (HsGroup id) -- [d| decls |] + | TypBr (LHsType id) -- [t| type |] + | VarBr id -- 'x, ''T + +instance OutputableBndr id => Outputable (HsBracket id) where + ppr = pprHsBracket + + +pprHsBracket (ExpBr e) = thBrackets empty (ppr e) +pprHsBracket (PatBr p) = thBrackets (char 'p') (ppr p) +pprHsBracket (DecBr d) = thBrackets (char 'd') (ppr d) +pprHsBracket (TypBr t) = thBrackets (char 't') (ppr t) +pprHsBracket (VarBr n) = char '\'' <> ppr n + -- Infelicity: can't show ' vs '', because + -- we can't ask n what its OccName is, because the + -- pretty-printer for HsExpr doesn't ask for NamedThings + -- But the pretty-printer for names will show the OccName class + +thBrackets pp_kind pp_body = char '[' <> pp_kind <> char '|' <+> + pp_body <+> ptext SLIT("|]") +\end{code} + +%************************************************************************ +%* * +\subsection{Enumerations and list comprehensions} +%* * +%************************************************************************ + +\begin{code} +data ArithSeqInfo id + = From (LHsExpr id) + | FromThen (LHsExpr id) + (LHsExpr id) + | FromTo (LHsExpr id) + (LHsExpr id) + | FromThenTo (LHsExpr id) + (LHsExpr id) + (LHsExpr id) +\end{code} + +\begin{code} +instance OutputableBndr id => Outputable (ArithSeqInfo id) where + ppr (From e1) = hcat [ppr e1, pp_dotdot] + ppr (FromThen e1 e2) = hcat [ppr e1, comma, space, ppr e2, pp_dotdot] + ppr (FromTo e1 e3) = hcat [ppr e1, pp_dotdot, ppr e3] + ppr (FromThenTo e1 e2 e3) + = hcat [ppr e1, comma, space, ppr e2, pp_dotdot, ppr e3] + +pp_dotdot = ptext SLIT(" .. ") +\end{code} + + +%************************************************************************ +%* * +\subsection{HsMatchCtxt} +%* * +%************************************************************************ + +\begin{code} +data HsMatchContext id -- Context of a Match + = FunRhs id -- Function binding for f + | CaseAlt -- Guard on a case alternative + | LambdaExpr -- Pattern of a lambda + | ProcExpr -- Pattern of a proc + | PatBindRhs -- Pattern binding + | RecUpd -- Record update [used only in DsExpr to tell matchWrapper + -- what sort of runtime error message to generate] + | StmtCtxt (HsStmtContext id) -- Pattern of a do-stmt or list comprehension + deriving () + +data HsStmtContext id + = ListComp + | DoExpr + | MDoExpr PostTcTable -- Recursive do-expression + -- (tiresomely, it needs table + -- of its return/bind ops) + | PArrComp -- Parallel array comprehension + | PatGuard (HsMatchContext id) -- Pattern guard for specified thing + | ParStmtCtxt (HsStmtContext id) -- A branch of a parallel stmt +\end{code} + +\begin{code} +isDoExpr :: HsStmtContext id -> Bool +isDoExpr DoExpr = True +isDoExpr (MDoExpr _) = True +isDoExpr other = False +\end{code} + +\begin{code} +matchSeparator (FunRhs _) = ptext SLIT("=") +matchSeparator CaseAlt = ptext SLIT("->") +matchSeparator LambdaExpr = ptext SLIT("->") +matchSeparator ProcExpr = ptext SLIT("->") +matchSeparator PatBindRhs = ptext SLIT("=") +matchSeparator (StmtCtxt _) = ptext SLIT("<-") +matchSeparator RecUpd = panic "unused" +\end{code} + +\begin{code} +pprMatchContext (FunRhs fun) = ptext SLIT("the definition of") <+> quotes (ppr fun) +pprMatchContext CaseAlt = ptext SLIT("a case alternative") +pprMatchContext RecUpd = ptext SLIT("a record-update construct") +pprMatchContext PatBindRhs = ptext SLIT("a pattern binding") +pprMatchContext LambdaExpr = ptext SLIT("a lambda abstraction") +pprMatchContext ProcExpr = ptext SLIT("an arrow abstraction") +pprMatchContext (StmtCtxt ctxt) = ptext SLIT("a pattern binding in") $$ pprStmtContext ctxt + +pprMatchRhsContext (FunRhs fun) = ptext SLIT("a right-hand side of function") <+> quotes (ppr fun) +pprMatchRhsContext CaseAlt = ptext SLIT("the body of a case alternative") +pprMatchRhsContext PatBindRhs = ptext SLIT("the right-hand side of a pattern binding") +pprMatchRhsContext LambdaExpr = ptext SLIT("the body of a lambda") +pprMatchRhsContext ProcExpr = ptext SLIT("the body of a proc") +pprMatchRhsContext RecUpd = panic "pprMatchRhsContext" + +pprStmtContext (ParStmtCtxt c) = sep [ptext SLIT("a parallel branch of"), pprStmtContext c] +pprStmtContext (PatGuard ctxt) = ptext SLIT("a pattern guard for") $$ pprMatchContext ctxt +pprStmtContext DoExpr = ptext SLIT("a 'do' expression") +pprStmtContext (MDoExpr _) = ptext SLIT("an 'mdo' expression") +pprStmtContext ListComp = ptext SLIT("a list comprehension") +pprStmtContext PArrComp = ptext SLIT("an array comprehension") + +-- Used for the result statement of comprehension +-- e.g. the 'e' in [ e | ... ] +-- or the 'r' in f x = r +pprStmtResultContext (PatGuard ctxt) = pprMatchRhsContext ctxt +pprStmtResultContext other = ptext SLIT("the result of") <+> pprStmtContext other + + +-- Used to generate the string for a *runtime* error message +matchContextErrString (FunRhs fun) = "function " ++ showSDoc (ppr fun) +matchContextErrString CaseAlt = "case" +matchContextErrString PatBindRhs = "pattern binding" +matchContextErrString RecUpd = "record update" +matchContextErrString LambdaExpr = "lambda" +matchContextErrString ProcExpr = "proc" +matchContextErrString (StmtCtxt (ParStmtCtxt c)) = matchContextErrString (StmtCtxt c) +matchContextErrString (StmtCtxt (PatGuard _)) = "pattern guard" +matchContextErrString (StmtCtxt DoExpr) = "'do' expression" +matchContextErrString (StmtCtxt (MDoExpr _)) = "'mdo' expression" +matchContextErrString (StmtCtxt ListComp) = "list comprehension" +matchContextErrString (StmtCtxt PArrComp) = "array comprehension" +\end{code} diff --git a/compiler/hsSyn/HsExpr.lhs-boot b/compiler/hsSyn/HsExpr.lhs-boot new file mode 100644 index 0000000000..503701bf66 --- /dev/null +++ b/compiler/hsSyn/HsExpr.lhs-boot @@ -0,0 +1,27 @@ +\begin{code} +module HsExpr where + +import SrcLoc ( Located ) +import Outputable ( SDoc, OutputableBndr ) +import {-# SOURCE #-} HsPat ( LPat ) + +data HsExpr i +data HsSplice i +data MatchGroup a +data GRHSs a + +type LHsExpr a = Located (HsExpr a) +type SyntaxExpr a = HsExpr a + +pprExpr :: (OutputableBndr i) => + HsExpr i -> SDoc + +pprSplice :: (OutputableBndr i) => + HsSplice i -> SDoc + +pprPatBind :: (OutputableBndr b, OutputableBndr i) => + LPat b -> GRHSs i -> SDoc + +pprFunBind :: (OutputableBndr i) => + i -> MatchGroup i -> SDoc +\end{code} diff --git a/compiler/hsSyn/HsImpExp.lhs b/compiler/hsSyn/HsImpExp.lhs new file mode 100644 index 0000000000..220afb7499 --- /dev/null +++ b/compiler/hsSyn/HsImpExp.lhs @@ -0,0 +1,125 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +% +\section[HsImpExp]{Abstract syntax: imports, exports, interfaces} + +\begin{code} +module HsImpExp where + +#include "HsVersions.h" + +import Module ( Module ) +import Outputable +import FastString +import SrcLoc ( Located(..) ) +import Char ( isAlpha ) +\end{code} + +%************************************************************************ +%* * +\subsection{Import and export declaration lists} +%* * +%************************************************************************ + +One per \tr{import} declaration in a module. +\begin{code} +type LImportDecl name = Located (ImportDecl name) + +data ImportDecl name + = ImportDecl (Located Module) -- module name + Bool -- True <=> {-# SOURCE #-} import + Bool -- True => qualified + (Maybe Module) -- as Module + (Maybe (Bool, [LIE name])) -- (True => hiding, names) +\end{code} + +\begin{code} +instance (Outputable name) => Outputable (ImportDecl name) where + ppr (ImportDecl mod from qual as spec) + = hang (hsep [ptext SLIT("import"), ppr_imp from, + pp_qual qual, ppr mod, pp_as as]) + 4 (pp_spec spec) + where + pp_qual False = empty + pp_qual True = ptext SLIT("qualified") + + pp_as Nothing = empty + pp_as (Just a) = ptext SLIT("as ") <+> ppr a + + ppr_imp True = ptext SLIT("{-# SOURCE #-}") + ppr_imp False = empty + + pp_spec Nothing = empty + pp_spec (Just (False, spec)) + = parens (interpp'SP spec) + pp_spec (Just (True, spec)) + = ptext SLIT("hiding") <+> parens (interpp'SP spec) + +ideclName (ImportDecl mod_nm _ _ _ _) = mod_nm +\end{code} + +%************************************************************************ +%* * +\subsection{Imported and exported entities} +%* * +%************************************************************************ + +\begin{code} +type LIE name = Located (IE name) + +data IE name + = IEVar name + | IEThingAbs name -- Class/Type (can't tell) + | IEThingAll name -- Class/Type plus all methods/constructors + | IEThingWith name [name] -- Class/Type plus some methods/constructors + | IEModuleContents Module -- (Export Only) +\end{code} + +\begin{code} +ieName :: IE name -> name +ieName (IEVar n) = n +ieName (IEThingAbs n) = n +ieName (IEThingWith n _) = n +ieName (IEThingAll n) = n + +ieNames :: IE a -> [a] +ieNames (IEVar n ) = [n] +ieNames (IEThingAbs n ) = [n] +ieNames (IEThingAll n ) = [n] +ieNames (IEThingWith n ns) = n:ns +ieNames (IEModuleContents _ ) = [] +\end{code} + +\begin{code} +instance (Outputable name) => Outputable (IE name) where + ppr (IEVar var) = pprHsVar var + ppr (IEThingAbs thing) = ppr thing + ppr (IEThingAll thing) = hcat [ppr thing, text "(..)"] + ppr (IEThingWith thing withs) + = ppr thing <> parens (fsep (punctuate comma (map pprHsVar withs))) + ppr (IEModuleContents mod) + = ptext SLIT("module") <+> ppr mod +\end{code} + +\begin{code} +pprHsVar :: Outputable name => name -> SDoc +pprHsVar v | isOperator ppr_v = parens ppr_v + | otherwise = ppr_v + where + ppr_v = ppr v + +isOperator :: SDoc -> Bool +isOperator ppr_v + = case showSDocUnqual ppr_v of + ('(':s) -> False -- (), (,) etc + ('[':s) -> False -- [] + ('$':c:s) -> not (isAlpha c) -- Don't treat $d as an operator + (':':c:s) -> not (isAlpha c) -- Don't treat :T as an operator + ('_':s) -> False -- Not an operator + (c:s) -> not (isAlpha c) -- Starts with non-alpha + other -> False + -- We use (showSDoc (ppr v)), rather than isSymOcc (getOccName v) simply so + -- that we don't need NamedThing in the context of all these functions. + -- Gruesome, but simple. +\end{code} + diff --git a/compiler/hsSyn/HsLit.lhs b/compiler/hsSyn/HsLit.lhs new file mode 100644 index 0000000000..c6d7e5dbea --- /dev/null +++ b/compiler/hsSyn/HsLit.lhs @@ -0,0 +1,96 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +% +\section[HsLit]{Abstract syntax: source-language literals} + +\begin{code} +module HsLit where + +#include "HsVersions.h" + +import {-# SOURCE #-} HsExpr( SyntaxExpr ) +import Type ( Type ) +import Outputable +import FastString +import Ratio ( Rational ) +\end{code} + + +%************************************************************************ +%* * +\subsection[HsLit]{Literals} +%* * +%************************************************************************ + + +\begin{code} +data HsLit + = HsChar Char -- Character + | HsCharPrim Char -- Unboxed character + | HsString FastString -- String + | HsStringPrim FastString -- Packed string + | HsInt Integer -- Genuinely an Int; arises from TcGenDeriv, + -- and from TRANSLATION + | HsIntPrim Integer -- Unboxed Int + | HsInteger Integer Type -- Genuinely an integer; arises only from TRANSLATION + -- (overloaded literals are done with HsOverLit) + | HsRat Rational Type -- Genuinely a rational; arises only from TRANSLATION + -- (overloaded literals are done with HsOverLit) + | HsFloatPrim Rational -- Unboxed Float + | HsDoublePrim Rational -- Unboxed Double + +instance Eq HsLit where + (HsChar x1) == (HsChar x2) = x1==x2 + (HsCharPrim x1) == (HsCharPrim x2) = x1==x2 + (HsString x1) == (HsString x2) = x1==x2 + (HsStringPrim x1) == (HsStringPrim x2) = x1==x2 + (HsInt x1) == (HsInt x2) = x1==x2 + (HsIntPrim x1) == (HsIntPrim x2) = x1==x2 + (HsInteger x1 _) == (HsInteger x2 _) = x1==x2 + (HsRat x1 _) == (HsRat x2 _) = x1==x2 + (HsFloatPrim x1) == (HsFloatPrim x2) = x1==x2 + (HsDoublePrim x1) == (HsDoublePrim x2) = x1==x2 + lit1 == lit2 = False + +data HsOverLit id -- An overloaded literal + = HsIntegral Integer (SyntaxExpr id) -- Integer-looking literals; + | HsFractional Rational (SyntaxExpr id) -- Frac-looking literals + -- Before type checking, the SyntaxExpr is 'fromInteger' or 'fromRational' + -- After type checking, it is (fromInteger 3) or lit_78; that is, + -- the expression that should replace the literal. + -- This is unusual, because we're replacing 'fromInteger' with a call + -- to fromInteger. Reason: it allows commoning up of the fromInteger + -- calls, which wouldn't be possible if the desguarar made the application + +-- Comparison operations are needed when grouping literals +-- for compiling pattern-matching (module MatchLit) +instance Eq (HsOverLit id) where + (HsIntegral i1 _) == (HsIntegral i2 _) = i1 == i2 + (HsFractional f1 _) == (HsFractional f2 _) = f1 == f2 + l1 == l2 = False + +instance Ord (HsOverLit id) where + compare (HsIntegral i1 _) (HsIntegral i2 _) = i1 `compare` i2 + compare (HsIntegral _ _) (HsFractional _ _) = LT + compare (HsFractional f1 _) (HsFractional f2 _) = f1 `compare` f2 + compare (HsFractional f1 _) (HsIntegral _ _) = GT +\end{code} + +\begin{code} +instance Outputable HsLit where + -- Use "show" because it puts in appropriate escapes + ppr (HsChar c) = pprHsChar c + ppr (HsCharPrim c) = pprHsChar c <> char '#' + ppr (HsString s) = pprHsString s + ppr (HsStringPrim s) = pprHsString s <> char '#' + ppr (HsInt i) = integer i + ppr (HsInteger i _) = integer i + ppr (HsRat f _) = rational f + ppr (HsFloatPrim f) = rational f <> char '#' + ppr (HsDoublePrim d) = rational d <> text "##" + ppr (HsIntPrim i) = integer i <> char '#' + +instance Outputable (HsOverLit id) where + ppr (HsIntegral i _) = integer i + ppr (HsFractional f _) = rational f +\end{code} diff --git a/compiler/hsSyn/HsPat.hi-boot-5 b/compiler/hsSyn/HsPat.hi-boot-5 new file mode 100644 index 0000000000..1f02ce3d47 --- /dev/null +++ b/compiler/hsSyn/HsPat.hi-boot-5 @@ -0,0 +1,6 @@ +__interface HsPat 1 0 where +__export Pat LPat ; + +1 data Pat i ; +1 type LPat i = SrcLoc.Located (Pat i) ; + diff --git a/compiler/hsSyn/HsPat.hi-boot-6 b/compiler/hsSyn/HsPat.hi-boot-6 new file mode 100644 index 0000000000..593caf2d17 --- /dev/null +++ b/compiler/hsSyn/HsPat.hi-boot-6 @@ -0,0 +1,4 @@ +module HsPat where + +data Pat i +type LPat i = SrcLoc.Located (Pat i) diff --git a/compiler/hsSyn/HsPat.lhs b/compiler/hsSyn/HsPat.lhs new file mode 100644 index 0000000000..953d228942 --- /dev/null +++ b/compiler/hsSyn/HsPat.lhs @@ -0,0 +1,324 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +% +\section[PatSyntax]{Abstract Haskell syntax---patterns} + +\begin{code} +module HsPat ( + Pat(..), InPat, OutPat, LPat, + + HsConDetails(..), hsConArgs, + + mkPrefixConPat, mkCharLitPat, mkNilPat, + + isBangHsBind, + patsAreAllCons, isConPat, isSigPat, isWildPat, + patsAreAllLits, isLitPat, isIrrefutableHsPat + ) where + +#include "HsVersions.h" + + +import {-# SOURCE #-} HsExpr ( SyntaxExpr ) + +-- friends: +import HsBinds ( DictBinds, HsBind(..), emptyLHsBinds, pprLHsBinds ) +import HsLit ( HsLit(HsCharPrim), HsOverLit ) +import HsTypes ( LHsType, PostTcType ) +import BasicTypes ( Boxity, tupleParens ) +-- others: +import PprCore ( {- instance OutputableBndr TyVar -} ) +import TysWiredIn ( nilDataCon, charDataCon, charTy ) +import Var ( TyVar ) +import DataCon ( DataCon, dataConTyCon ) +import TyCon ( isProductTyCon ) +import Outputable +import Type ( Type ) +import SrcLoc ( Located(..), unLoc, noLoc ) +\end{code} + + +\begin{code} +type InPat id = LPat id -- No 'Out' constructors +type OutPat id = LPat id -- No 'In' constructors + +type LPat id = Located (Pat id) + +data Pat id + = ------------ Simple patterns --------------- + WildPat PostTcType -- Wild card + | VarPat id -- Variable + | VarPatOut id (DictBinds id) -- Used only for overloaded Ids; the + -- bindings give its overloaded instances + | LazyPat (LPat id) -- Lazy pattern + | AsPat (Located id) (LPat id) -- As pattern + | ParPat (LPat id) -- Parenthesised pattern + | BangPat (LPat id) -- Bang patterng + + ------------ Lists, tuples, arrays --------------- + | ListPat [LPat id] -- Syntactic list + PostTcType -- The type of the elements + + | TuplePat [LPat id] -- Tuple + Boxity -- UnitPat is TuplePat [] + PostTcType + -- You might think that the PostTcType was redundant, but it's essential + -- data T a where + -- T1 :: Int -> T Int + -- f :: (T a, a) -> Int + -- f (T1 x, z) = z + -- When desugaring, we must generate + -- f = /\a. \v::a. case v of (t::T a, w::a) -> + -- case t of (T1 (x::Int)) -> + -- Note the (w::a), NOT (w::Int), because we have not yet + -- refined 'a' to Int. So we must know that the second component + -- of the tuple is of type 'a' not Int. See selectMatchVar + + | PArrPat [LPat id] -- Syntactic parallel array + PostTcType -- The type of the elements + + ------------ Constructor patterns --------------- + | ConPatIn (Located id) + (HsConDetails id (LPat id)) + + | ConPatOut (Located DataCon) + [TyVar] -- Existentially bound type variables + [id] -- Ditto dictionaries + (DictBinds id) -- Bindings involving those dictionaries + (HsConDetails id (LPat id)) + Type -- The type of the pattern + + ------------ Literal and n+k patterns --------------- + | LitPat HsLit -- Used for *non-overloaded* literal patterns: + -- Int#, Char#, Int, Char, String, etc. + + | NPat (HsOverLit id) -- ALWAYS positive + (Maybe (SyntaxExpr id)) -- Just (Name of 'negate') for negative + -- patterns, Nothing otherwise + (SyntaxExpr id) -- Equality checker, of type t->t->Bool + PostTcType -- Type of the pattern + + | NPlusKPat (Located id) -- n+k pattern + (HsOverLit id) -- It'll always be an HsIntegral + (SyntaxExpr id) -- (>=) function, of type t->t->Bool + (SyntaxExpr id) -- Name of '-' (see RnEnv.lookupSyntaxName) + + ------------ Generics --------------- + | TypePat (LHsType id) -- Type pattern for generic definitions + -- e.g f{| a+b |} = ... + -- These show up only in class declarations, + -- and should be a top-level pattern + + ------------ Pattern type signatures --------------- + | SigPatIn (LPat id) -- Pattern with a type signature + (LHsType id) + + | SigPatOut (LPat id) -- Pattern with a type signature + Type + + ------------ Dictionary patterns (translation only) --------------- + | DictPat -- Used when destructing Dictionaries with an explicit case + [id] -- superclass dicts + [id] -- methods +\end{code} + +HsConDetails is use both for patterns and for data type declarations + +\begin{code} +data HsConDetails id arg + = PrefixCon [arg] -- C p1 p2 p3 + | RecCon [(Located id, arg)] -- C { x = p1, y = p2 } + | InfixCon arg arg -- p1 `C` p2 + +hsConArgs :: HsConDetails id arg -> [arg] +hsConArgs (PrefixCon ps) = ps +hsConArgs (RecCon fs) = map snd fs +hsConArgs (InfixCon p1 p2) = [p1,p2] +\end{code} + + +%************************************************************************ +%* * +%* Printing patterns +%* * +%************************************************************************ + +\begin{code} +instance (OutputableBndr name) => Outputable (Pat name) where + ppr = pprPat + +pprPatBndr :: OutputableBndr name => name -> SDoc +pprPatBndr var -- Print with type info if -dppr-debug is on + = getPprStyle $ \ sty -> + if debugStyle sty then + parens (pprBndr LambdaBind var) -- Could pass the site to pprPat + -- but is it worth it? + else + ppr var + +pprPat :: (OutputableBndr name) => Pat name -> SDoc +pprPat (VarPat var) = pprPatBndr var +pprPat (VarPatOut var bs) = parens (pprPatBndr var <+> braces (ppr bs)) +pprPat (WildPat _) = char '_' +pprPat (LazyPat pat) = char '~' <> ppr pat +pprPat (BangPat pat) = char '!' <> ppr pat +pprPat (AsPat name pat) = parens (hcat [ppr name, char '@', ppr pat]) +pprPat (ParPat pat) = parens (ppr pat) +pprPat (ListPat pats _) = brackets (interpp'SP pats) +pprPat (PArrPat pats _) = pabrackets (interpp'SP pats) +pprPat (TuplePat pats bx _) = tupleParens bx (interpp'SP pats) + +pprPat (ConPatIn con details) = pprUserCon con details +pprPat (ConPatOut con tvs dicts binds details _) + = getPprStyle $ \ sty -> -- Tiresome; in TcBinds.tcRhs we print out a + if debugStyle sty then -- typechecked Pat in an error message, + -- and we want to make sure it prints nicely + ppr con <+> sep [ hsep (map pprPatBndr tvs) <+> hsep (map pprPatBndr dicts), + pprLHsBinds binds, pprConArgs details] + else pprUserCon con details + +pprPat (LitPat s) = ppr s +pprPat (NPat l Nothing _ _) = ppr l +pprPat (NPat l (Just _) _ _) = char '-' <> ppr l +pprPat (NPlusKPat n k _ _) = hcat [ppr n, char '+', ppr k] +pprPat (TypePat ty) = ptext SLIT("{|") <> ppr ty <> ptext SLIT("|}") +pprPat (SigPatIn pat ty) = ppr pat <+> dcolon <+> ppr ty +pprPat (SigPatOut pat ty) = ppr pat <+> dcolon <+> ppr ty +pprPat (DictPat ds ms) = parens (sep [ptext SLIT("{-dict-}"), + brackets (interpp'SP ds), + brackets (interpp'SP ms)]) + +pprUserCon c (InfixCon p1 p2) = ppr p1 <+> ppr c <+> ppr p2 +pprUserCon c details = ppr c <+> pprConArgs details + +pprConArgs (PrefixCon pats) = interppSP pats +pprConArgs (InfixCon p1 p2) = interppSP [p1,p2] +pprConArgs (RecCon rpats) = braces (hsep (punctuate comma (map (pp_rpat) rpats))) + where + pp_rpat (v, p) = hsep [ppr v, char '=', ppr p] + + +-- add parallel array brackets around a document +-- +pabrackets :: SDoc -> SDoc +pabrackets p = ptext SLIT("[:") <> p <> ptext SLIT(":]") +\end{code} + + +%************************************************************************ +%* * +%* Building patterns +%* * +%************************************************************************ + +\begin{code} +mkPrefixConPat :: DataCon -> [OutPat id] -> Type -> OutPat id +-- Make a vanilla Prefix constructor pattern +mkPrefixConPat dc pats ty = noLoc $ ConPatOut (noLoc dc) [] [] emptyLHsBinds (PrefixCon pats) ty + +mkNilPat :: Type -> OutPat id +mkNilPat ty = mkPrefixConPat nilDataCon [] ty + +mkCharLitPat :: Char -> OutPat id +mkCharLitPat c = mkPrefixConPat charDataCon [noLoc $ LitPat (HsCharPrim c)] charTy +\end{code} + + +%************************************************************************ +%* * +%* Predicates for checking things about pattern-lists in EquationInfo * +%* * +%************************************************************************ + +\subsection[Pat-list-predicates]{Look for interesting things in patterns} + +Unlike in the Wadler chapter, where patterns are either ``variables'' +or ``constructors,'' here we distinguish between: +\begin{description} +\item[unfailable:] +Patterns that cannot fail to match: variables, wildcards, and lazy +patterns. + +These are the irrefutable patterns; the two other categories +are refutable patterns. + +\item[constructor:] +A non-literal constructor pattern (see next category). + +\item[literal patterns:] +At least the numeric ones may be overloaded. +\end{description} + +A pattern is in {\em exactly one} of the above three categories; `as' +patterns are treated specially, of course. + +The 1.3 report defines what ``irrefutable'' and ``failure-free'' patterns are. +\begin{code} +isWildPat (WildPat _) = True +isWildPat other = False + +patsAreAllCons :: [Pat id] -> Bool +patsAreAllCons pat_list = all isConPat pat_list + +isConPat (AsPat _ pat) = isConPat (unLoc pat) +isConPat (ConPatIn _ _) = True +isConPat (ConPatOut _ _ _ _ _ _) = True +isConPat (ListPat _ _) = True +isConPat (PArrPat _ _) = True +isConPat (TuplePat _ _ _) = True +isConPat (DictPat ds ms) = (length ds + length ms) > 1 +isConPat other = False + +isSigPat (SigPatIn _ _) = True +isSigPat (SigPatOut _ _) = True +isSigPat other = False + +patsAreAllLits :: [Pat id] -> Bool +patsAreAllLits pat_list = all isLitPat pat_list + +isLitPat (AsPat _ pat) = isLitPat (unLoc pat) +isLitPat (LitPat _) = True +isLitPat (NPat _ _ _ _) = True +isLitPat (NPlusKPat _ _ _ _) = True +isLitPat other = False + +isBangHsBind :: HsBind id -> Bool +-- In this module because HsPat is above HsBinds in the import graph +isBangHsBind (PatBind { pat_lhs = L _ (BangPat p) }) = True +isBangHsBind bind = False + +isIrrefutableHsPat :: LPat id -> Bool +-- This function returns False if it's in doubt; specifically +-- on a ConPatIn it doesn't know the size of the constructor family +-- But if it returns True, the pattern is definitely irrefutable +isIrrefutableHsPat pat + = go pat + where + go (L _ pat) = go1 pat + + go1 (WildPat _) = True + go1 (VarPat _) = True + go1 (VarPatOut _ _) = True + go1 (LazyPat pat) = True + go1 (BangPat pat) = go pat + go1 (ParPat pat) = go pat + go1 (AsPat _ pat) = go pat + go1 (SigPatIn pat _) = go pat + go1 (SigPatOut pat _) = go pat + go1 (TuplePat pats _ _) = all go pats + go1 (ListPat pats _) = False + go1 (PArrPat pats _) = False -- ? + + go1 (ConPatIn _ _) = False -- Conservative + go1 (ConPatOut (L _ con) _ _ _ details _) + = isProductTyCon (dataConTyCon con) + && all go (hsConArgs details) + + go1 (LitPat _) = False + go1 (NPat _ _ _ _) = False + go1 (NPlusKPat _ _ _ _) = False + + go1 (TypePat _) = panic "isIrrefutableHsPat: type pattern" + go1 (DictPat _ _) = panic "isIrrefutableHsPat: type pattern" +\end{code} + diff --git a/compiler/hsSyn/HsPat.lhs-boot b/compiler/hsSyn/HsPat.lhs-boot new file mode 100644 index 0000000000..d5b685c1f1 --- /dev/null +++ b/compiler/hsSyn/HsPat.lhs-boot @@ -0,0 +1,7 @@ +\begin{code} +module HsPat where +import SrcLoc( Located ) + +data Pat i +type LPat i = Located (Pat i) +\end{code} diff --git a/compiler/hsSyn/HsSyn.lhs b/compiler/hsSyn/HsSyn.lhs new file mode 100644 index 0000000000..a9982a630a --- /dev/null +++ b/compiler/hsSyn/HsSyn.lhs @@ -0,0 +1,98 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +% +\section{Haskell abstract syntax definition} + +This module glues together the pieces of the Haskell abstract syntax, +which is declared in the various \tr{Hs*} modules. This module, +therefore, is almost nothing but re-exporting. + +\begin{code} +module HsSyn ( + module HsBinds, + module HsDecls, + module HsExpr, + module HsImpExp, + module HsLit, + module HsPat, + module HsTypes, + module HsUtils, + Fixity, + + HsModule(..), HsExtCore(..) + ) where + +#include "HsVersions.h" + +-- friends: +import HsDecls +import HsBinds +import HsExpr +import HsImpExp +import HsLit +import HsPat +import HsTypes +import HscTypes ( DeprecTxt ) +import BasicTypes ( Fixity ) +import HsUtils + +-- others: +import IfaceSyn ( IfaceBinding ) +import Outputable +import SrcLoc ( Located(..) ) +import Module ( Module ) +\end{code} + +All we actually declare here is the top-level structure for a module. +\begin{code} +data HsModule name + = HsModule + (Maybe (Located Module))-- Nothing => "module X where" is omitted + -- (in which case the next field is Nothing too) + (Maybe [LIE name]) -- Export list; Nothing => export list omitted, so export everything + -- Just [] => export *nothing* + -- Just [...] => as you would expect... + [LImportDecl name] -- We snaffle interesting stuff out of the + -- imported interfaces early on, adding that + -- info to TyDecls/etc; so this list is + -- often empty, downstream. + [LHsDecl name] -- Type, class, value, and interface signature decls + (Maybe DeprecTxt) -- reason/explanation for deprecation of this module + +data HsExtCore name -- Read from Foo.hcr + = HsExtCore + Module + [TyClDecl name] -- Type declarations only; just as in Haskell source, + -- so that we can infer kinds etc + [IfaceBinding] -- And the bindings +\end{code} + +\begin{code} +instance (OutputableBndr name) + => Outputable (HsModule name) where + + ppr (HsModule Nothing _ imports decls _) + = pp_nonnull imports $$ pp_nonnull decls + + ppr (HsModule (Just name) exports imports decls deprec) + = vcat [ + case exports of + Nothing -> pp_header (ptext SLIT("where")) + Just es -> vcat [ + pp_header lparen, + nest 8 (fsep (punctuate comma (map ppr es))), + nest 4 (ptext SLIT(") where")) + ], + pp_nonnull imports, + pp_nonnull decls + ] + where + pp_header rest = case deprec of + Nothing -> pp_modname <+> rest + Just d -> vcat [ pp_modname, ppr d, rest ] + + pp_modname = ptext SLIT("module") <+> ppr name + +pp_nonnull [] = empty +pp_nonnull xs = vcat (map ppr xs) +\end{code} diff --git a/compiler/hsSyn/HsTypes.lhs b/compiler/hsSyn/HsTypes.lhs new file mode 100644 index 0000000000..f1343a39ef --- /dev/null +++ b/compiler/hsSyn/HsTypes.lhs @@ -0,0 +1,370 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +% +\section[HsTypes]{Abstract syntax: user-defined types} + +\begin{code} +module HsTypes ( + HsType(..), LHsType, + HsTyVarBndr(..), LHsTyVarBndr, + HsExplicitForAll(..), + HsContext, LHsContext, + HsPred(..), LHsPred, + + LBangType, BangType, HsBang(..), + getBangType, getBangStrictness, + + mkExplicitHsForAllTy, mkImplicitHsForAllTy, + hsTyVarName, hsTyVarNames, replaceTyVarName, + hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsLTyVarLocNames, + splitHsInstDeclTy, splitHsFunType, + + -- Type place holder + PostTcType, placeHolderType, + + -- Printing + pprParendHsType, pprHsForAll, pprHsContext, ppr_hs_context, pprHsTyVarBndr + ) where + +#include "HsVersions.h" + +import {-# SOURCE #-} HsExpr ( HsSplice, pprSplice ) + +import Type ( Type ) +import Kind ( {- instance Outputable Kind -}, Kind, + pprParendKind, pprKind, isLiftedTypeKind ) +import BasicTypes ( IPName, Boxity, tupleParens ) +import SrcLoc ( Located(..), unLoc, noSrcSpan ) +import StaticFlags ( opt_PprStyle_Debug ) +import Outputable +\end{code} + + +%************************************************************************ +%* * +\subsection{Annotating the syntax} +%* * +%************************************************************************ + +\begin{code} +type PostTcType = Type -- Used for slots in the abstract syntax + -- where we want to keep slot for a type + -- to be added by the type checker...but + -- before typechecking it's just bogus + +placeHolderType :: PostTcType -- Used before typechecking +placeHolderType = panic "Evaluated the place holder for a PostTcType" +\end{code} + +%************************************************************************ +%* * +\subsection{Bang annotations} +%* * +%************************************************************************ + +\begin{code} +type LBangType name = Located (BangType name) +type BangType name = HsType name -- Bangs are in the HsType data type + +data HsBang = HsNoBang -- Only used as a return value for getBangStrictness, + -- never appears on a HsBangTy + | HsStrict -- ! + | HsUnbox -- {-# UNPACK #-} ! (GHC extension, meaning "unbox") + +instance Outputable HsBang where + ppr (HsNoBang) = empty + ppr (HsStrict) = char '!' + ppr (HsUnbox) = ptext SLIT("!!") + +getBangType :: LHsType a -> LHsType a +getBangType (L _ (HsBangTy _ ty)) = ty +getBangType ty = ty + +getBangStrictness :: LHsType a -> HsBang +getBangStrictness (L _ (HsBangTy s _)) = s +getBangStrictness _ = HsNoBang +\end{code} + + +%************************************************************************ +%* * +\subsection{Data types} +%* * +%************************************************************************ + +This is the syntax for types as seen in type signatures. + +\begin{code} +type LHsContext name = Located (HsContext name) + +type HsContext name = [LHsPred name] + +type LHsPred name = Located (HsPred name) + +data HsPred name = HsClassP name [LHsType name] + | HsIParam (IPName name) (LHsType name) + +type LHsType name = Located (HsType name) + +data HsType name + = HsForAllTy HsExplicitForAll -- Renamer leaves this flag unchanged, to record the way + -- the user wrote it originally, so that the printer can + -- print it as the user wrote it + [LHsTyVarBndr name] -- With ImplicitForAll, this is the empty list + -- until the renamer fills in the variables + (LHsContext name) + (LHsType name) + + | HsTyVar name -- Type variable or type constructor + + | HsBangTy HsBang (LHsType name) -- Bang-style type annotations + + | HsAppTy (LHsType name) + (LHsType name) + + | HsFunTy (LHsType name) -- function type + (LHsType name) + + | HsListTy (LHsType name) -- Element type + + | HsPArrTy (LHsType name) -- Elem. type of parallel array: [:t:] + + | HsTupleTy Boxity + [LHsType name] -- Element types (length gives arity) + + | HsOpTy (LHsType name) (Located name) (LHsType name) + + | HsParTy (LHsType name) + -- Parenthesis preserved for the precedence re-arrangement in RnTypes + -- It's important that a * (b + c) doesn't get rearranged to (a*b) + c! + -- + -- However, NB that toHsType doesn't add HsParTys (in an effort to keep + -- interface files smaller), so when printing a HsType we may need to + -- add parens. + + | HsNumTy Integer -- Generics only + + | HsPredTy (HsPred name) -- Only used in the type of an instance + -- declaration, eg. Eq [a] -> Eq a + -- ^^^^ + -- HsPredTy + -- Note no need for location info on the + -- enclosed HsPred; the one on the type will do + + | HsKindSig (LHsType name) -- (ty :: kind) + Kind -- A type with a kind signature + + | HsSpliceTy (HsSplice name) + +data HsExplicitForAll = Explicit | Implicit + +----------------------- +-- Combine adjacent for-alls. +-- The following awkward situation can happen otherwise: +-- f :: forall a. ((Num a) => Int) +-- might generate HsForAll (Just [a]) [] (HsForAll Nothing [Num a] t) +-- Then a isn't discovered as ambiguous, and we abstract the AbsBinds wrt [] +-- but the export list abstracts f wrt [a]. Disaster. +-- +-- A valid type must have one for-all at the top of the type, or of the fn arg types + +mkImplicitHsForAllTy ctxt ty = mkHsForAllTy Implicit [] ctxt ty +mkExplicitHsForAllTy tvs ctxt ty = mkHsForAllTy Explicit tvs ctxt ty + +mkHsForAllTy :: HsExplicitForAll -> [LHsTyVarBndr name] -> LHsContext name -> LHsType name -> HsType name +-- Smart constructor for HsForAllTy +mkHsForAllTy exp tvs (L _ []) ty = mk_forall_ty exp tvs ty +mkHsForAllTy exp tvs ctxt ty = HsForAllTy exp tvs ctxt ty + +-- mk_forall_ty makes a pure for-all type (no context) +mk_forall_ty exp tvs (L _ (HsParTy ty)) = mk_forall_ty exp tvs ty +mk_forall_ty exp1 tvs1 (L _ (HsForAllTy exp2 tvs2 ctxt ty)) = mkHsForAllTy (exp1 `plus` exp2) (tvs1 ++ tvs2) ctxt ty +mk_forall_ty exp tvs ty = HsForAllTy exp tvs (L noSrcSpan []) ty + -- Even if tvs is empty, we still make a HsForAll! + -- In the Implicit case, this signals the place to do implicit quantification + -- In the Explicit case, it prevents implicit quantification + -- (see the sigtype production in Parser.y.pp) + -- so that (forall. ty) isn't implicitly quantified + +Implicit `plus` Implicit = Implicit +exp1 `plus` exp2 = Explicit + +type LHsTyVarBndr name = Located (HsTyVarBndr name) + +data HsTyVarBndr name + = UserTyVar name + | KindedTyVar name Kind + -- *** NOTA BENE *** A "monotype" in a pragma can have + -- for-alls in it, (mostly to do with dictionaries). These + -- must be explicitly Kinded. + +hsTyVarName :: HsTyVarBndr name -> name +hsTyVarName (UserTyVar n) = n +hsTyVarName (KindedTyVar n _) = n + +hsLTyVarName :: LHsTyVarBndr name -> name +hsLTyVarName = hsTyVarName . unLoc + +hsTyVarNames :: [HsTyVarBndr name] -> [name] +hsTyVarNames tvs = map hsTyVarName tvs + +hsLTyVarNames :: [LHsTyVarBndr name] -> [name] +hsLTyVarNames = map hsLTyVarName + +hsLTyVarLocName :: LHsTyVarBndr name -> Located name +hsLTyVarLocName = fmap hsTyVarName + +hsLTyVarLocNames :: [LHsTyVarBndr name] -> [Located name] +hsLTyVarLocNames = map hsLTyVarLocName + +replaceTyVarName :: HsTyVarBndr name1 -> name2 -> HsTyVarBndr name2 +replaceTyVarName (UserTyVar n) n' = UserTyVar n' +replaceTyVarName (KindedTyVar n k) n' = KindedTyVar n' k +\end{code} + + +\begin{code} +splitHsInstDeclTy + :: OutputableBndr name + => HsType name + -> ([LHsTyVarBndr name], HsContext name, name, [LHsType name]) + -- Split up an instance decl type, returning the pieces + +splitHsInstDeclTy inst_ty + = case inst_ty of + HsParTy (L _ ty) -> splitHsInstDeclTy ty + HsForAllTy _ tvs cxt (L _ ty) -> split_tau tvs (unLoc cxt) ty + other -> split_tau [] [] other + -- The type vars should have been computed by now, even if they were implicit + where + split_tau tvs cxt (HsPredTy (HsClassP cls tys)) = (tvs, cxt, cls, tys) + split_tau tvs cxt (HsParTy (L _ ty)) = split_tau tvs cxt ty + +-- Splits HsType into the (init, last) parts +-- Breaks up any parens in the result type: +-- splitHsFunType (a -> (b -> c)) = ([a,b], c) +splitHsFunType :: LHsType name -> ([LHsType name], LHsType name) +splitHsFunType (L l (HsFunTy x y)) = (x:args, res) + where + (args, res) = splitHsFunType y +splitHsFunType (L _ (HsParTy ty)) = splitHsFunType ty +splitHsFunType other = ([], other) +\end{code} + + +%************************************************************************ +%* * +\subsection{Pretty printing} +%* * +%************************************************************************ + +NB: these types get printed into interface files, so + don't change the printing format lightly + +\begin{code} +instance (OutputableBndr name) => Outputable (HsType name) where + ppr ty = pprHsType ty + +instance (Outputable name) => Outputable (HsTyVarBndr name) where + ppr (UserTyVar name) = ppr name + ppr (KindedTyVar name kind) = pprHsTyVarBndr name kind + +instance OutputableBndr name => Outputable (HsPred name) where + ppr (HsClassP clas tys) = ppr clas <+> hsep (map (pprParendHsType.unLoc) tys) + ppr (HsIParam n ty) = hsep [ppr n, dcolon, ppr ty] + +pprHsTyVarBndr :: Outputable name => name -> Kind -> SDoc +pprHsTyVarBndr name kind | isLiftedTypeKind kind = ppr name + | otherwise = hsep [ppr name, dcolon, pprParendKind kind] + +pprHsForAll exp tvs cxt + | show_forall = forall_part <+> pprHsContext (unLoc cxt) + | otherwise = pprHsContext (unLoc cxt) + where + show_forall = opt_PprStyle_Debug + || (not (null tvs) && is_explicit) + is_explicit = case exp of {Explicit -> True; Implicit -> False} + forall_part = ptext SLIT("forall") <+> interppSP tvs <> dot + +pprHsContext :: (OutputableBndr name) => HsContext name -> SDoc +pprHsContext [] = empty +pprHsContext cxt = ppr_hs_context cxt <+> ptext SLIT("=>") + +ppr_hs_context [] = empty +ppr_hs_context cxt = parens (interpp'SP cxt) +\end{code} + +\begin{code} +pREC_TOP = (0 :: Int) -- type in ParseIface.y +pREC_FUN = (1 :: Int) -- btype in ParseIface.y + -- Used for LH arg of (->) +pREC_OP = (2 :: Int) -- Used for arg of any infix operator + -- (we don't keep their fixities around) +pREC_CON = (3 :: Int) -- Used for arg of type applicn: + -- always parenthesise unless atomic + +maybeParen :: Int -- Precedence of context + -> Int -- Precedence of top-level operator + -> SDoc -> SDoc -- Wrap in parens if (ctxt >= op) +maybeParen ctxt_prec op_prec p | ctxt_prec >= op_prec = parens p + | otherwise = p + +-- printing works more-or-less as for Types + +pprHsType, pprParendHsType :: (OutputableBndr name) => HsType name -> SDoc + +pprHsType ty = getPprStyle $ \sty -> ppr_mono_ty pREC_TOP (prepare sty ty) +pprParendHsType ty = ppr_mono_ty pREC_CON ty + +-- Before printing a type +-- (a) Remove outermost HsParTy parens +-- (b) Drop top-level for-all type variables in user style +-- since they are implicit in Haskell +prepare sty (HsParTy ty) = prepare sty (unLoc ty) +prepare sty ty = ty + +ppr_mono_lty ctxt_prec ty = ppr_mono_ty ctxt_prec (unLoc ty) + +ppr_mono_ty ctxt_prec (HsForAllTy exp tvs ctxt ty) + = maybeParen ctxt_prec pREC_FUN $ + sep [pprHsForAll exp tvs ctxt, ppr_mono_lty pREC_TOP ty] + +-- gaw 2004 +ppr_mono_ty ctxt_prec (HsBangTy b ty) = ppr b <> ppr ty +ppr_mono_ty ctxt_prec (HsTyVar name) = ppr name +ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) = ppr_fun_ty ctxt_prec ty1 ty2 +ppr_mono_ty ctxt_prec (HsTupleTy con tys) = tupleParens con (interpp'SP tys) +ppr_mono_ty ctxt_prec (HsKindSig ty kind) = parens (ppr_mono_lty pREC_TOP ty <+> dcolon <+> pprKind kind) +ppr_mono_ty ctxt_prec (HsListTy ty) = brackets (ppr_mono_lty pREC_TOP ty) +ppr_mono_ty ctxt_prec (HsPArrTy ty) = pabrackets (ppr_mono_lty pREC_TOP ty) +ppr_mono_ty ctxt_prec (HsPredTy pred) = braces (ppr pred) +ppr_mono_ty ctxt_prec (HsNumTy n) = integer n -- generics only +ppr_mono_ty ctxt_prec (HsSpliceTy s) = pprSplice s + +ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) + = maybeParen ctxt_prec pREC_CON $ + hsep [ppr_mono_lty pREC_FUN fun_ty, ppr_mono_lty pREC_CON arg_ty] + +ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) + = maybeParen ctxt_prec pREC_OP $ + ppr_mono_lty pREC_OP ty1 <+> ppr op <+> ppr_mono_lty pREC_OP ty2 + +ppr_mono_ty ctxt_prec (HsParTy ty) + = parens (ppr_mono_lty pREC_TOP ty) + -- Put the parens in where the user did + -- But we still use the precedence stuff to add parens because + -- toHsType doesn't put in any HsParTys, so we may still need them + +-------------------------- +ppr_fun_ty ctxt_prec ty1 ty2 + = let p1 = ppr_mono_lty pREC_FUN ty1 + p2 = ppr_mono_lty pREC_TOP ty2 + in + maybeParen ctxt_prec pREC_FUN $ + sep [p1, ptext SLIT("->") <+> p2] + +-------------------------- +pabrackets p = ptext SLIT("[:") <> p <> ptext SLIT(":]") +\end{code} + + diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs new file mode 100644 index 0000000000..d9c45e6529 --- /dev/null +++ b/compiler/hsSyn/HsUtils.lhs @@ -0,0 +1,423 @@ +% +% (c) The University of Glasgow, 1992-2003 +% + +Here we collect a variety of helper functions that construct or +analyse HsSyn. All these functions deal with generic HsSyn; functions +which deal with the intantiated versions are located elsewhere: + + Parameterised by Module + ---------------- ------------- + RdrName parser/RdrHsSyn + Name rename/RnHsSyn + Id typecheck/TcHsSyn + +\begin{code} +module HsUtils where + +#include "HsVersions.h" + +import HsBinds +import HsExpr +import HsPat +import HsTypes +import HsLit + +import RdrName ( RdrName, getRdrName, mkRdrUnqual ) +import Var ( Id ) +import Type ( Type ) +import DataCon ( DataCon, dataConWrapId, dataConSourceArity ) +import OccName ( mkVarOccFS ) +import Name ( Name ) +import BasicTypes ( RecFlag(..) ) +import SrcLoc +import FastString ( mkFastString ) +import Outputable +import Util ( nOfThem ) +import Bag +\end{code} + + +%************************************************************************ +%* * + Some useful helpers for constructing syntax +%* * +%************************************************************************ + +These functions attempt to construct a not-completely-useless SrcSpan +from their components, compared with the nl* functions below which +just attach noSrcSpan to everything. + +\begin{code} +mkHsPar :: LHsExpr id -> LHsExpr id +mkHsPar e = L (getLoc e) (HsPar e) + +-- gaw 2004 +mkSimpleMatch :: [LPat id] -> LHsExpr id -> LMatch id +mkSimpleMatch pats rhs + = L loc $ + Match pats Nothing (GRHSs (unguardedRHS rhs) emptyLocalBinds) + where + loc = case pats of + [] -> getLoc rhs + (pat:_) -> combineSrcSpans (getLoc pat) (getLoc rhs) + +unguardedRHS :: LHsExpr id -> [LGRHS id] +unguardedRHS rhs@(L loc _) = [L loc (GRHS [] rhs)] + +mkHsAppTy :: LHsType name -> LHsType name -> LHsType name +mkHsAppTy t1 t2 = addCLoc t1 t2 (HsAppTy t1 t2) + +mkHsApp :: LHsExpr name -> LHsExpr name -> LHsExpr name +mkHsApp e1 e2 = addCLoc e1 e2 (HsApp e1 e2) + +mkHsTyApp :: LHsExpr name -> [Type] -> LHsExpr name +mkHsTyApp expr [] = expr +mkHsTyApp expr tys = L (getLoc expr) (TyApp expr tys) + +mkHsDictApp :: LHsExpr name -> [name] -> LHsExpr name +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 + matches = mkMatchGroup [mkSimpleMatch pats body] + +mkMatchGroup :: [LMatch id] -> MatchGroup id +mkMatchGroup matches = MatchGroup matches placeHolderType + +mkHsTyLam [] expr = expr +mkHsTyLam tyvars expr = L (getLoc expr) (TyLam tyvars expr) + +mkHsDictLam [] expr = expr +mkHsDictLam dicts expr = L (getLoc expr) (DictLam dicts expr) + +mkHsDictLet :: LHsBinds Id -> LHsExpr Id -> LHsExpr Id +-- Used for the dictionary bindings gotten from TcSimplify +-- We make them recursive to be on the safe side +mkHsDictLet binds expr + | isEmptyLHsBinds binds = expr + | otherwise = L (getLoc expr) (HsLet (HsValBinds val_binds) expr) + where + val_binds = ValBindsOut [(Recursive, binds)] [] + +mkHsConApp :: DataCon -> [Type] -> [HsExpr Id] -> LHsExpr Id +-- Used for constructing dictinoary terms etc, so no locations +mkHsConApp data_con tys args + = foldl mk_app (noLoc (HsVar (dataConWrapId data_con)) `mkHsTyApp` tys) args + where + mk_app f a = noLoc (HsApp f (noLoc a)) + +mkSimpleHsAlt :: LPat id -> LHsExpr id -> LMatch id +-- A simple lambda with a single pattern, no binds, no guards; pre-typechecking +mkSimpleHsAlt pat expr + = mkSimpleMatch [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 +mkHsDo ctxt stmts body = HsDo ctxt stmts body placeHolderType + +mkNPat lit neg = NPat lit neg noSyntaxExpr placeHolderType +mkNPlusKPat id lit = NPlusKPat id lit noSyntaxExpr noSyntaxExpr + +mkExprStmt expr = ExprStmt expr noSyntaxExpr placeHolderType +mkBindStmt pat expr = BindStmt pat expr noSyntaxExpr noSyntaxExpr +mkRecStmt stmts = RecStmt stmts [] [] [] emptyLHsBinds + +------------------------------- +--- A useful function for building @OpApps@. The operator is always a +-- variable, and we don't know the fixity yet. +mkHsOpApp e1 op e2 = OpApp e1 (noLoc (HsVar op)) (error "mkOpApp:fixity") e2 + +mkHsSplice e = HsSplice unqualSplice e + +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} + + +%************************************************************************ +%* * + Constructing syntax with no location info +%* * +%************************************************************************ + +\begin{code} +nlHsVar :: id -> LHsExpr id +nlHsVar n = noLoc (HsVar n) + +nlHsLit :: HsLit -> LHsExpr id +nlHsLit n = noLoc (HsLit n) + +nlVarPat :: id -> LPat id +nlVarPat n = noLoc (VarPat n) + +nlLitPat :: HsLit -> LPat id +nlLitPat l = noLoc (LitPat l) + +nlHsApp :: LHsExpr id -> LHsExpr id -> LHsExpr id +nlHsApp f x = noLoc (HsApp f x) + +nlHsIntLit n = noLoc (HsLit (HsInt n)) + +nlHsApps :: id -> [LHsExpr id] -> LHsExpr id +nlHsApps f xs = foldl nlHsApp (nlHsVar f) xs + +nlHsVarApps :: id -> [id] -> LHsExpr id +nlHsVarApps f xs = noLoc (foldl mk (HsVar f) (map HsVar xs)) + where + mk f a = HsApp (noLoc f) (noLoc a) + +nlConVarPat :: id -> [id] -> LPat id +nlConVarPat con vars = nlConPat con (map nlVarPat vars) + +nlInfixConPat :: id -> LPat id -> LPat id -> LPat id +nlInfixConPat con l r = noLoc (ConPatIn (noLoc con) (InfixCon l r)) + +nlConPat :: id -> [LPat id] -> LPat id +nlConPat con pats = noLoc (ConPatIn (noLoc con) (PrefixCon pats)) + +nlNullaryConPat :: id -> LPat id +nlNullaryConPat con = noLoc (ConPatIn (noLoc con) (PrefixCon [])) + +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 = noLoc (WildPat placeHolderType) -- Pre-typechecking + +nlHsDo :: HsStmtContext Name -> [LStmt id] -> LHsExpr id -> LHsExpr id +nlHsDo ctxt stmts body = noLoc (mkHsDo ctxt stmts body) + +nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2) + +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 f t = noLoc (HsAppTy f t) +nlHsTyVar x = noLoc (HsTyVar x) +nlHsFunTy a b = noLoc (HsFunTy a b) +\end{code} + + + +%************************************************************************ +%* * + Bindings; with a location at the top +%* * +%************************************************************************ + +\begin{code} +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 -> RdrName -> [LPat RdrName] + -> LHsExpr RdrName -> LHsBind RdrName + +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 loc fun [] = panic "TcGenDeriv:mk_FunBind" +mk_FunBind loc fun pats_and_exprs + = L loc $ mkFunBind (L loc fun) matches + where + matches = [mkMatch p e emptyLocalBinds | (p,e) <-pats_and_exprs] + +------------ +mkMatch :: [LPat id] -> LHsExpr id -> HsLocalBinds id -> LMatch id +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) +\end{code} + + +%************************************************************************ +%* * + Collecting binders from HsBindGroups and HsBinds +%* * +%************************************************************************ + +Get all the binders in some HsBindGroups, IN THE ORDER OF APPEARANCE. eg. + +... +where + (x, y) = ... + f i j = ... + [a, b] = ... + +it should return [x, y, f, a, b] (remember, order important). + +\begin{code} +collectLocalBinders :: HsLocalBinds name -> [Located name] +collectLocalBinders (HsValBinds val_binds) = collectHsValBinders val_binds +collectLocalBinders (HsIPBinds _) = [] +collectLocalBinders EmptyLocalBinds = [] + +collectHsValBinders :: HsValBinds name -> [Located name] +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_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 + -- The only time we collect binders from a typechecked + -- binding (hence see AbsBinds) is in zonking in TcHsSyn + +collectHsBindBinders :: LHsBinds name -> [name] +collectHsBindBinders binds = map unLoc (collectHsBindLocatedBinders binds) + +collectHsBindLocatedBinders :: LHsBinds name -> [Located name] +collectHsBindLocatedBinders binds = foldrBag (collectAcc . unLoc) [] binds +\end{code} + + +%************************************************************************ +%* * + Getting binders from statements +%* * +%************************************************************************ + +\begin{code} +collectLStmtsBinders :: [LStmt id] -> [Located id] +collectLStmtsBinders = concatMap collectLStmtBinders + +collectStmtsBinders :: [Stmt id] -> [Located id] +collectStmtsBinders = concatMap collectStmtBinders + +collectLStmtBinders :: LStmt id -> [Located id] +collectLStmtBinders = collectStmtBinders . unLoc + +collectStmtBinders :: Stmt id -> [Located id] + -- 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 (RecStmt ss _ _ _ _) = collectLStmtsBinders ss +collectStmtBinders other = panic "collectStmtBinders" +\end{code} + + +%************************************************************************ +%* * +%* Gathering stuff out of patterns +%* * +%************************************************************************ + +This function @collectPatBinders@ works with the ``collectBinders'' +functions for @HsBinds@, etc. The order in which the binders are +collected is important; see @HsBinds.lhs@. + +It collects the bounds *value* variables in renamed patterns; type variables +are *not* collected. + +\begin{code} +collectPatBinders :: LPat a -> [a] +collectPatBinders pat = map unLoc (collectLocatedPatBinders pat) + +collectLocatedPatBinders :: LPat a -> [Located a] +collectLocatedPatBinders pat = collectl pat [] + +collectPatsBinders :: [LPat a] -> [a] +collectPatsBinders pats = map unLoc (collectLocatedPatsBinders pats) + +collectLocatedPatsBinders :: [LPat a] -> [Located a] +collectLocatedPatsBinders pats = foldr collectl [] pats + +--------------------- +collectl (L l pat) bndrs + = go pat + where + go (VarPat var) = L l var : bndrs + go (VarPatOut var bs) = L l var : collectHsBindLocatedBinders bs + ++ 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 (ConPatIn c ps) = foldr collectl bndrs (hsConArgs ps) + go (ConPatOut c _ ds bs ps _) = map noLoc ds + ++ collectHsBindLocatedBinders bs + ++ foldr collectl bndrs (hsConArgs ps) + go (LitPat _) = bndrs + go (NPat _ _ _ _) = bndrs + go (NPlusKPat n _ _ _) = n : bndrs + + go (SigPatIn pat _) = collectl pat bndrs + go (SigPatOut pat _) = collectl pat bndrs + go (TypePat ty) = bndrs + go (DictPat ids1 ids2) = map noLoc ids1 ++ map noLoc ids2 + ++ bndrs +\end{code} + +\begin{code} +collectSigTysFromPats :: [InPat name] -> [LHsType name] +collectSigTysFromPats pats = foldr collect_lpat [] pats + +collectSigTysFromPat :: InPat name -> [LHsType name] +collectSigTysFromPat pat = collect_lpat pat [] + +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 (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} |