X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fparser%2FParseUtil.lhs;h=3bec98e035610332f9465a4b32af0414f705a1e5;hb=2205f0ceeb65d8acb7db953bf4fd2ad673dc55ee;hp=a679d3aafde5909c4636f994a56a0609100c0ea4;hpb=0b3442ccd2158dac03910aefce7d0d43c6ea88ad;p=ghc-hetmet.git diff --git a/ghc/compiler/parser/ParseUtil.lhs b/ghc/compiler/parser/ParseUtil.lhs index a679d3a..3bec98e 100644 --- a/ghc/compiler/parser/ParseUtil.lhs +++ b/ghc/compiler/parser/ParseUtil.lhs @@ -5,62 +5,55 @@ \begin{code} module ParseUtil ( - parseError -- String -> Pa - , srcParseErr -- StringBuffer -> SrcLoc -> Message - , cbot -- a - , splitForConApp -- RdrNameHsType -> [RdrNameBangType] - -- -> P (RdrName, [RdrNameBangType]) + parseError -- String -> Pa + , mkVanillaCon, mkRecCon, - , mkRecConstrOrUpdate -- HsExp -> [HsFieldUpdate] -> P HsExp + , mkRecConstrOrUpdate -- HsExp -> [HsFieldUpdate] -> P HsExp , groupBindings - , mkExtName -- Maybe ExtName -> RdrName -> ExtName - - , checkPrec -- String -> P String - , checkContext -- HsType -> P HsContext - , checkInstType -- HsType -> P HsType - , checkAssertion -- HsType -> P HsAsst - , checkDataHeader -- HsQualType -> P (HsContext,HsName,[HsName]) - , checkSimple -- HsType -> [HsName] -> P ((HsName,[HsName])) - , checkPattern -- HsExp -> P HsPat - , checkPatterns -- [HsExp] -> P [HsPat] - -- , checkExpr -- HsExp -> P HsExp - , checkValDef -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl - - - -- some built-in names (all :: RdrName) - , unitCon_RDR, unitTyCon_RDR, nilCon_RDR, listTyCon_RDR - , tupleCon_RDR, tupleTyCon_RDR, ubxTupleCon_RDR, ubxTupleTyCon_RDR - , funTyCon_RDR - - -- pseudo-keywords, in var and tyvar forms (all :: RdrName) - , as_var_RDR, hiding_var_RDR, qualified_var_RDR, forall_var_RDR - , export_var_RDR, label_var_RDR, dynamic_var_RDR, unsafe_var_RDR - , stdcall_var_RDR, ccall_var_RDR - - , as_tyvar_RDR, hiding_tyvar_RDR, qualified_tyvar_RDR - , export_tyvar_RDR, label_tyvar_RDR, dynamic_tyvar_RDR - , unsafe_tyvar_RDR, stdcall_tyvar_RDR, ccall_tyvar_RDR - - , minus_RDR, pling_RDR, dot_RDR - + , mkIfaceExports -- :: [RdrNameTyClDecl] -> [RdrExportItem] + + , CallConv(..) + , mkImport -- CallConv -> Safety + -- -> (FastString, RdrName, RdrNameHsType) + -- -> SrcLoc + -- -> P RdrNameHsDecl + , mkExport -- CallConv + -- -> (FastString, RdrName, RdrNameHsType) + -- -> SrcLoc + -- -> P RdrNameHsDecl + , mkExtName -- RdrName -> CLabelString + + , checkPrec -- String -> P String + , checkContext -- HsType -> P HsContext + , checkPred -- HsType -> P HsPred + , checkTyVars -- [HsTyVar] -> P [HsType] + , checkTyClHdr -- HsType -> (name,[tyvar]) + , checkInstType -- HsType -> P HsType + , checkPattern -- HsExp -> P HsPat + , checkPatterns -- SrcLoc -> [HsExp] -> P [HsPat] + , checkDo -- [Stmt] -> P [Stmt] + , checkValDef -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl + , checkValSig -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl ) where #include "HsVersions.h" +import List ( isSuffixOf ) + import Lex -import HsSyn +import HscTypes ( RdrAvailInfo, GenAvailInfo(..) ) +import HsSyn -- Lots of it +import ForeignCall ( CCallConv, Safety, CCallTarget(..), CExportSpec(..), + DNCallSpec(..)) import SrcLoc import RdrHsSyn import RdrName -import CallConv -import PrelMods ( pRELUDE_Name, mkUbxTupNameStr, mkTupNameStr ) -import OccName ( dataName, tcName, varName, tvName, setOccNameSpace, occNameFS ) -import CmdLineOpts ( opt_NoImplicitPrelude ) -import StringBuffer ( lexemeToString ) -import FastString ( unpackFS ) -import ErrUtils -import UniqFM ( UniqFM, listToUFM, lookupUFM ) +import PrelNames ( unitTyCon_RDR ) +import OccName ( dataName, varName, tcClsName, isDataOcc, + occNameSpace, setOccNameSpace, occNameUserString ) +import CStrings ( CLabelString ) +import FastString import Outputable ----------------------------------------------------------------------------- @@ -71,112 +64,141 @@ parseError s = getSrcLocP `thenP` \ loc -> failMsgP (hcat [ppr loc, text ": ", text s]) -srcParseErr :: StringBuffer -> SrcLoc -> Message -srcParseErr s l - = hcat [ppr l, - if null token - then ptext SLIT(": parse error (possibly incorrect indentation)") - else hcat [ptext SLIT(": parse error on input "), - char '`', text token, char '\''] - ] - where - token = lexemeToString s - -cbot = panic "CCall:result_ty" ----------------------------------------------------------------------------- --- splitForConApp +-- mkVanillaCon -- When parsing data declarations, we sometimes inadvertently parse -- a constructor application as a type (eg. in data T a b = C a b `D` E a b) -- This function splits up the type application, adds any pending -- arguments, and converts the type constructor back into a data constructor. -splitForConApp :: RdrNameHsType -> [RdrNameBangType] - -> P (RdrName, [RdrNameBangType]) +mkVanillaCon :: RdrNameHsType -> [RdrNameBangType] -> P (RdrName, RdrNameConDetails) -splitForConApp t ts = split t ts +mkVanillaCon ty tys + = split ty tys where - split (MonoTyApp t u) ts = split t (Unbanged u : ts) - - split (MonoTyVar t) ts = returnP (con, ts) - where t_occ = rdrNameOcc t - con = setRdrNameOcc t (setOccNameSpace t_occ dataName) + split (HsAppTy t u) ts = split t (unbangedType u : ts) + split (HsTyVar tc) ts = tyConToDataCon tc `thenP` \ data_con -> + returnP (data_con, VanillaCon ts) + split _ _ = parseError "Illegal data/newtype declaration" + +mkRecCon :: RdrName -> [([RdrName],RdrNameBangType)] -> P (RdrName, RdrNameConDetails) +mkRecCon con fields + = tyConToDataCon con `thenP` \ data_con -> + returnP (data_con, RecCon fields) + +tyConToDataCon :: RdrName -> P RdrName +tyConToDataCon tc + | occNameSpace tc_occ == tcClsName + = returnP (setRdrNameOcc tc (setOccNameSpace tc_occ dataName)) + | otherwise + = parseError (showSDoc (text "Not a constructor:" <+> quotes (ppr tc))) + where + tc_occ = rdrNameOcc tc - split _ _ = parseError "Illegal data/newtype declaration" ---------------------------------------------------------------------------- -- Various Syntactic Checks -callConvFM :: UniqFM CallConv -callConvFM = listToUFM $ - map (\ (x,y) -> (_PK_ x,y)) - [ ("stdcall", stdCallConv), - ("ccall", cCallConv) --- ("pascal", pascalCallConv), --- ("fastcall", fastCallConv) - ] - -checkCallConv :: FAST_STRING -> P CallConv -checkCallConv s = - case lookupUFM callConvFM s of - Nothing -> parseError ("unknown calling convention: `" - ++ unpackFS s ++ "'") - Just conv -> returnP conv - checkInstType :: RdrNameHsType -> P RdrNameHsType checkInstType t = case t of HsForAllTy tvs ctxt ty -> - checkAssertion ty [] `thenP` \(c,ts)-> - returnP (HsForAllTy tvs ctxt (MonoDictTy c ts)) - - ty -> checkAssertion ty [] `thenP` \(c,ts)-> - returnP (HsForAllTy Nothing [] (MonoDictTy c ts)) + checkDictTy ty [] `thenP` \ dict_ty -> + returnP (HsForAllTy tvs ctxt dict_ty) + + HsParTy ty -> checkInstType ty + + ty -> checkDictTy ty [] `thenP` \ dict_ty-> + returnP (HsForAllTy Nothing [] dict_ty) + +checkTyVars :: [RdrNameHsType] -> P [RdrNameHsTyVar] +checkTyVars tvs = mapP chk tvs + where + chk (HsKindSig (HsTyVar tv) k) = returnP (IfaceTyVar tv k) + chk (HsTyVar tv) = returnP (UserTyVar tv) + chk other = parseError "Type found where type variable expected" + +checkTyClHdr :: RdrNameHsType -> P (RdrName, [RdrNameHsTyVar]) +-- The header of a type or class decl should look like +-- (C a, D b) => T a b +-- or T a b +-- or a + b +-- etc +checkTyClHdr ty + = go ty [] + where + go (HsTyVar tc) acc + | not (isRdrTyVar tc) = checkTyVars acc `thenP` \ tvs -> + returnP (tc, tvs) + go (HsOpTy t1 (HsTyOp tc) t2) acc + = checkTyVars (t1:t2:acc) `thenP` \ tvs -> + returnP (tc, tvs) + go (HsParTy ty) acc = go ty acc + go (HsAppTy t1 t2) acc = go t1 (t2:acc) + go other acc = parseError "Malformed LHS to type of class declaration" checkContext :: RdrNameHsType -> P RdrNameContext -checkContext (MonoTupleTy ts True) - = mapP (\t -> checkAssertion t []) ts `thenP` \cs -> - returnP cs -checkContext (MonoTyVar t) -- empty contexts are allowed +checkContext (HsTupleTy _ ts) -- (Eq a, Ord b) shows up as a tuple type + = mapP checkPred ts + +checkContext (HsParTy ty) -- to be sure HsParTy doesn't get into the way + = checkContext ty + +checkContext (HsTyVar t) -- Empty context shows up as a unit type () | t == unitTyCon_RDR = returnP [] + checkContext t - = checkAssertion t [] `thenP` \c -> - returnP [c] - -checkAssertion :: RdrNameHsType -> [RdrNameHsType] - -> P (ClassAssertion RdrName) -checkAssertion (MonoTyVar t) args@(_:_) | not (isRdrTyVar t) - = returnP (t,args) -checkAssertion (MonoTyApp l r) args = checkAssertion l (r:args) -checkAssertion _ _ = parseError "Illegal class assertion" - -checkDataHeader :: RdrNameHsType - -> P (RdrNameContext, RdrName, [RdrNameHsTyVar]) -checkDataHeader (HsForAllTy Nothing cs t) = - checkSimple t [] `thenP` \(c,ts) -> - returnP (cs,c,map UserTyVar ts) -checkDataHeader t = - checkSimple t [] `thenP` \(c,ts) -> - returnP ([],c,map UserTyVar ts) - -checkSimple :: RdrNameHsType -> [RdrName] -> P ((RdrName,[RdrName])) -checkSimple (MonoTyApp l (MonoTyVar a)) xs | isRdrTyVar a - = checkSimple l (a:xs) -checkSimple (MonoTyVar t) xs | not (isRdrTyVar t) = returnP (t,xs) -checkSimple t _ = trace (showSDoc (ppr t)) $ parseError "Illegal data/newtype declaration" + = checkPred t `thenP` \p -> + returnP [p] + +checkPred :: RdrNameHsType -> P (HsPred RdrName) +-- Watch out.. in ...deriving( Show )... we use checkPred on +-- the list of partially applied predicates in the deriving, +-- so there can be zero args. +checkPred (HsPredTy (HsIParam n ty)) = returnP (HsIParam n ty) +checkPred ty + = go ty [] + where + go (HsTyVar t) args | not (isRdrTyVar t) + = returnP (HsClassP t args) + go (HsAppTy l r) args = go l (r:args) + go (HsParTy t) args = go t args + go _ _ = parseError "Illegal class assertion" + +checkDictTy :: RdrNameHsType -> [RdrNameHsType] -> P RdrNameHsType +checkDictTy (HsTyVar t) args@(_:_) | not (isRdrTyVar t) + = returnP (mkHsDictTy t args) +checkDictTy (HsAppTy l r) args = checkDictTy l (r:args) +checkDictTy (HsParTy t) args = checkDictTy t args +checkDictTy _ _ = parseError "Malformed context in instance header" + + +--------------------------------------------------------------------------- +-- Checking statements in a do-expression +-- We parse do { e1 ; e2 ; } +-- as [ExprStmt e1, ExprStmt e2] +-- checkDo (a) checks that the last thing is an ExprStmt +-- (b) transforms it to a ResultStmt + +checkDo [] = parseError "Empty 'do' construct" +checkDo [ExprStmt e _ l] = returnP [ResultStmt e l] +checkDo [s] = parseError "The last statement in a 'do' construct must be an expression" +checkDo (s:ss) = checkDo ss `thenP` \ ss' -> + returnP (s:ss') --------------------------------------------------------------------------- -- Checking Patterns. -- We parse patterns as expressions and check for valid patterns below, --- nverting the expression into a pattern at the same time. +-- converting the expression into a pattern at the same time. -checkPattern :: RdrNameHsExpr -> P RdrNamePat -checkPattern e = checkPat e [] +checkPattern :: SrcLoc -> RdrNameHsExpr -> P RdrNamePat +checkPattern loc e = setSrcLocP loc (checkPat e []) -checkPatterns :: [RdrNameHsExpr] -> P [RdrNamePat] -checkPatterns es = mapP checkPattern es +checkPatterns :: SrcLoc -> [RdrNameHsExpr] -> P [RdrNamePat] +checkPatterns loc es = mapP (checkPattern loc) es checkPat :: RdrNameHsExpr -> [RdrNamePat] -> P RdrNamePat checkPat (HsVar c) args | isRdrDataCon c = returnP (ConPatIn c args) @@ -187,10 +209,11 @@ checkPat e [] = case e of EWildPat -> returnP WildPatIn HsVar x -> returnP (VarPatIn x) HsLit l -> returnP (LitPatIn l) + HsOverLit l -> returnP (NPatIn l Nothing) ELazyPat e -> checkPat e [] `thenP` (returnP . LazyPatIn) EAsPat n e -> checkPat e [] `thenP` (returnP . AsPatIn n) ExprWithTySig e t -> checkPat e [] `thenP` \e -> - -- pattern signatures are parsed as sigtypes, + -- Pattern signatures are parsed as sigtypes, -- but they aren't explicit forall points. Hence -- we have to remove the implicit forall here. let t' = case t of @@ -199,24 +222,40 @@ checkPat e [] = case e of in returnP (SigPatIn e t') - OpApp (HsVar n) (HsVar plus) _ (HsLit k@(HsInt _)) | plus == plus_RDR - -> returnP (NPlusKPatIn n k) + -- Translate out NegApps of literals in patterns. We negate + -- the Integer here, and add back the call to 'negate' when + -- we typecheck the pattern. + -- NB. Negative *primitive* literals are already handled by + -- RdrHsSyn.mkHsNegApp + NegApp (HsOverLit lit) neg -> returnP (NPatIn lit (Just neg)) + + OpApp (HsVar n) (HsVar plus) _ (HsOverLit lit@(HsIntegral _ _)) + | plus == plus_RDR + -> returnP (mkNPlusKPat n lit) + where + plus_RDR = mkUnqual varName FSLIT("+") -- Hack OpApp l op fix r -> checkPat l [] `thenP` \l -> checkPat r [] `thenP` \r -> case op of - HsVar c -> returnP (ConOpPatIn l c fix r) + HsVar c | isDataOcc (rdrNameOcc c) + -> returnP (ConOpPatIn l c fix r) _ -> patFail - NegApp l r -> checkPat l [] `thenP` (returnP . NegPatIn) HsPar e -> checkPat e [] `thenP` (returnP . ParPatIn) - ExplicitList es -> mapP (\e -> checkPat e []) es `thenP` \ps -> + ExplicitList _ es -> mapP (\e -> checkPat e []) es `thenP` \ps -> returnP (ListPatIn ps) + ExplicitPArr _ es -> mapP (\e -> checkPat e []) es `thenP` \ps -> + returnP (PArrPatIn ps) + ExplicitTuple es b -> mapP (\e -> checkPat e []) es `thenP` \ps -> returnP (TuplePatIn ps b) + RecordCon c fs -> mapP checkPatField fs `thenP` \fs -> returnP (RecPatIn c fs) - _ -> patFail +-- Generics + HsType ty -> returnP (TypePatIn ty) + _ -> patFail checkPat _ _ = patFail @@ -228,91 +267,7 @@ checkPatField (n,e,b) = patFail = parseError "Parse error in pattern" ---------------------------------------------------------------------------- --- Check Expression Syntax - -{- -We can get away without checkExpr if the renamer generates errors for -pattern syntax used in expressions (wildcards, as patterns and lazy -patterns). - -checkExpr :: RdrNameHsExpr -> P RdrNameHsExpr -checkExpr e = case e of - HsVar _ -> returnP e - HsLit _ -> returnP e - HsLam match -> checkMatch match `thenP` (returnP.HsLam) - HsApp e1 e2 -> check2Exprs e1 e2 HsApp - OpApp e1 e2 fix e3 -> checkExpr e1 `thenP` \e1 -> - checkExpr e2 `thenP` \e2 -> - checkExpr e3 `thenP` \e3 -> - returnP (OpApp e1 e2 fix e3) - NegApp e neg -> checkExpr e `thenP` \e -> - returnP (NegApp e neg) - HsPar e -> check1Expr e HsPar - SectionL e1 e2 -> check2Exprs e1 e2 SectionL - SectionR e1 e2 -> check2Exprs e1 e2 SectionR - HsCase e alts -> mapP checkMatch alts `thenP` \alts -> - checkExpr e `thenP` \e -> - returnP (HsCase e alts) - HsIf e1 e2 e3 -> check3Exprs e1 e2 e3 HsIf - - HsLet bs e -> check1Expr e (HsLet bs) - HsDo stmts -> mapP checkStmt stmts `thenP` (returnP . HsDo) - HsTuple es -> checkManyExprs es HsTuple - HsList es -> checkManyExprs es HsList - HsRecConstr c fields -> mapP checkField fields `thenP` \fields -> - returnP (HsRecConstr c fields) - HsRecUpdate e fields -> mapP checkField fields `thenP` \fields -> - checkExpr e `thenP` \e -> - returnP (HsRecUpdate e fields) - HsEnumFrom e -> check1Expr e HsEnumFrom - HsEnumFromTo e1 e2 -> check2Exprs e1 e2 HsEnumFromTo - HsEnumFromThen e1 e2 -> check2Exprs e1 e2 HsEnumFromThen - HsEnumFromThenTo e1 e2 e3 -> check3Exprs e1 e2 e3 HsEnumFromThenTo - HsListComp e stmts -> mapP checkStmt stmts `thenP` \stmts -> - checkExpr e `thenP` \e -> - returnP (HsListComp e stmts) - RdrNameHsExprTypeSig loc e ty -> checkExpr e `thenP` \e -> - returnP (RdrNameHsExprTypeSig loc e ty) - _ -> parseError "parse error in expression" - --- type signature for polymorphic recursion!! -check1Expr :: RdrNameHsExpr -> (RdrNameHsExpr -> a) -> P a -check1Expr e f = checkExpr e `thenP` (returnP . f) - -check2Exprs :: RdrNameHsExpr -> RdrNameHsExpr -> (RdrNameHsExpr -> RdrNameHsExpr -> a) -> P a -check2Exprs e1 e2 f = - checkExpr e1 `thenP` \e1 -> - checkExpr e2 `thenP` \e2 -> - returnP (f e1 e2) - -check3Exprs :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr -> (RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr -> a) -> P a -check3Exprs e1 e2 e3 f = - checkExpr e1 `thenP` \e1 -> - checkExpr e2 `thenP` \e2 -> - checkExpr e3 `thenP` \e3 -> - returnP (f e1 e2 e3) - -checkManyExprs es f = - mapP checkExpr es `thenP` \es -> - returnP (f es) - -checkAlt (HsAlt loc p galts bs) - = checkGAlts galts `thenP` \galts -> returnP (HsAlt loc p galts bs) - -checkGAlts (HsUnGuardedAlt e) = check1Expr e HsUnGuardedAlt -checkGAlts (HsGuardedAlts galts) - = mapP checkGAlt galts `thenP` (returnP . HsGuardedAlts) - -checkGAlt (HsGuardedAlt loc e1 e2) = check2Exprs e1 e2 (HsGuardedAlt loc) - -checkStmt (HsGenerator p e) = check1Expr e (HsGenerator p) -checkStmt (HsQualifier e) = check1Expr e HsQualifier -checkStmt s@(HsLetStmt bs) = returnP s - -checkField (HsFieldUpdate n e) = check1Expr e (HsFieldUpdate n) -checkField e = returnP e --} + --------------------------------------------------------------------------- -- Check Equation Syntax @@ -321,26 +276,42 @@ checkValDef -> Maybe RdrNameHsType -> RdrNameGRHSs -> SrcLoc - -> P RdrNameMonoBinds + -> P RdrBinding checkValDef lhs opt_sig grhss loc = case isFunLhs lhs [] of Just (f,inf,es) -> - checkPatterns es `thenP` \ps -> - returnP (FunMonoBind f inf [Match [] ps opt_sig grhss] loc) + checkPatterns loc es `thenP` \ps -> + returnP (RdrValBinding (FunMonoBind f inf [Match ps opt_sig grhss] loc)) Nothing -> - checkPattern lhs `thenP` \lhs -> - returnP (PatMonoBind lhs grhss loc) + checkPattern loc lhs `thenP` \lhs -> + returnP (RdrValBinding (PatMonoBind lhs grhss loc)) --- A variable binding is parsed as an RdrNamePatBind. +checkValSig + :: RdrNameHsExpr + -> RdrNameHsType + -> SrcLoc + -> P RdrBinding +checkValSig (HsVar v) ty loc = returnP (RdrSig (Sig v ty loc)) +checkValSig other ty loc = parseError "Type signature given for an expression" + + +-- A variable binding is parsed as an RdrNameFunMonoBind. +-- See comments with HsBinds.MonoBinds +isFunLhs :: RdrNameHsExpr -> [RdrNameHsExpr] -> Maybe (RdrName, Bool, [RdrNameHsExpr]) isFunLhs (OpApp l (HsVar op) fix r) es | not (isRdrDataCon op) = Just (op, True, (l:r:es)) -isFunLhs (HsVar f) es@(_:_) | not (isRdrDataCon f) + | otherwise + = case isFunLhs l es of + Just (op', True, j : k : es') -> + Just (op', True, j : OpApp k (HsVar op) fix r : es') + _ -> Nothing +isFunLhs (HsVar f) es | not (isRdrDataCon f) = Just (f,False,es) isFunLhs (HsApp f e) es = isFunLhs f (e:es) -isFunLhs (HsPar e) es = isFunLhs e es +isFunLhs (HsPar e) es@(_:_) = isFunLhs e es isFunLhs _ _ = Nothing --------------------------------------------------------------------------- @@ -348,7 +319,7 @@ isFunLhs _ _ = Nothing checkPrec :: Integer -> P () checkPrec i | 0 <= i && i <= 9 = returnP () - | otherwise = parseError "precedence out of range" + | otherwise = parseError "Precedence out of range" mkRecConstrOrUpdate :: RdrNameHsExpr @@ -362,13 +333,107 @@ mkRecConstrOrUpdate exp fs@(_:_) mkRecConstrOrUpdate _ _ = parseError "Empty record update" --- supplying the ext_name in a foreign decl is optional ; if it +----------------------------------------------------------------------------- +-- utilities for foreign declarations + +-- supported calling conventions +-- +data CallConv = CCall CCallConv -- ccall or stdcall + | DNCall -- .NET + +-- construct a foreign import declaration +-- +mkImport :: CallConv + -> Safety + -> (FastString, RdrName, RdrNameHsType) + -> SrcLoc + -> P RdrNameHsDecl +mkImport (CCall cconv) safety (entity, v, ty) loc = + parseCImport entity cconv safety v `thenP` \importSpec -> + returnP $ ForD (ForeignImport v ty importSpec False loc) +mkImport (DNCall ) _ (entity, v, ty) loc = + returnP $ ForD (ForeignImport v ty (DNImport (DNCallSpec entity)) False loc) + +-- parse the entity string of a foreign import declaration for the `ccall' or +-- `stdcall' calling convention' +-- +parseCImport :: FastString + -> CCallConv + -> Safety + -> RdrName + -> P ForeignImport +parseCImport entity cconv safety v + -- FIXME: we should allow white space around `dynamic' and `wrapper' -=chak + | entity == FSLIT ("dynamic") = + returnP $ CImport cconv safety nilFS nilFS (CFunction DynamicTarget) + | entity == FSLIT ("wrapper") = + returnP $ CImport cconv safety nilFS nilFS CWrapper + | otherwise = parse0 (unpackFS entity) + where + -- using the static keyword? + parse0 (' ': rest) = parse0 rest + parse0 ('s':'t':'a':'t':'i':'c':rest) = parse1 rest + parse0 rest = parse1 rest + -- check for header file name + parse1 "" = parse4 "" nilFS False nilFS + parse1 (' ':rest) = parse1 rest + parse1 str@('&':_ ) = parse2 str nilFS + parse1 str@('[':_ ) = parse3 str nilFS False + parse1 str + | ".h" `isSuffixOf` first = parse2 rest (mkFastString first) + | otherwise = parse4 str nilFS False nilFS + where + (first, rest) = break (\c -> c == ' ' || c == '&' || c == '[') str + -- check for address operator (indicating a label import) + parse2 "" header = parse4 "" header False nilFS + parse2 (' ':rest) header = parse2 rest header + parse2 ('&':rest) header = parse3 rest header True + parse2 str@('[':_ ) header = parse3 str header False + parse2 str header = parse4 str header False nilFS + -- check for library object name + parse3 (' ':rest) header isLbl = parse3 rest header isLbl + parse3 ('[':rest) header isLbl = + case break (== ']') rest of + (lib, ']':rest) -> parse4 rest header isLbl (mkFastString lib) + _ -> parseError "Missing ']' in entity" + parse3 str header isLbl = parse4 str header isLbl nilFS + -- check for name of C function + parse4 "" header isLbl lib = build (mkExtName v) header isLbl lib + parse4 (' ':rest) header isLbl lib = parse4 rest header isLbl lib + parse4 str header isLbl lib + | all (== ' ') rest = build (mkFastString first) header isLbl lib + | otherwise = parseError "Malformed entity string" + where + (first, rest) = break (== ' ') str + -- + build cid header False lib = returnP $ + CImport cconv safety header lib (CFunction (StaticTarget cid)) + build cid header True lib = returnP $ + CImport cconv safety header lib (CLabel cid ) + +-- construct a foreign export declaration +-- +mkExport :: CallConv + -> (FastString, RdrName, RdrNameHsType) + -> SrcLoc + -> P RdrNameHsDecl +mkExport (CCall cconv) (entity, v, ty) loc = returnP $ + ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)) False loc) + where + entity' | nullFastString entity = mkExtName v + | otherwise = entity +mkExport DNCall (entity, v, ty) loc = + parseError "Foreign export is not yet supported for .NET" + +-- Supplying the ext_name in a foreign decl is optional; if it -- isn't there, the Haskell name is assumed. Note that no transformation -- of the Haskell name is then performed, so if you foreign export (++), --- it's external name will be "++". Too bad. -mkExtName :: Maybe ExtName -> RdrName -> ExtName -mkExtName Nothing rdrNm = ExtName (occNameFS (rdrNameOcc rdrNm)) Nothing -mkExtName (Just x) _ = x +-- it's external name will be "++". Too bad; it's important because we don't +-- want z-encoding (e.g. names with z's in them shouldn't be doubled) +-- (This is why we use occNameUserString.) +-- +mkExtName :: RdrName -> CLabelString +mkExtName rdrNm = mkFastString (occNameUserString (rdrNameOcc rdrNm)) ----------------------------------------------------------------------------- -- group function bindings into equation groups @@ -381,8 +446,15 @@ groupBindings binds = group Nothing binds where group :: Maybe RdrNameMonoBinds -> [RdrBinding] -> RdrBinding group (Just bind) [] = RdrValBinding bind group Nothing [] = RdrNullBind + + -- don't group together FunMonoBinds if they have + -- no arguments. This is necessary now that variable bindings + -- with no arguments are now treated as FunMonoBinds rather + -- than pattern bindings (tests/rename/should_fail/rnfail002). group (Just (FunMonoBind f inf1 mtchs ignore_srcloc)) - (RdrValBinding (FunMonoBind f' _ [mtch] loc) : binds) + (RdrValBinding (FunMonoBind f' _ + [mtch@(Match (_:_) _ _)] loc) + : binds) | f == f' = group (Just (FunMonoBind f inf1 (mtch:mtchs) loc)) binds group (Just so_far) binds @@ -392,93 +464,17 @@ groupBindings binds = group Nothing binds RdrValBinding b@(FunMonoBind _ _ _ _) -> group (Just b) binds other -> bind `RdrAndBindings` group Nothing binds ------------------------------------------------------------------------------ --- Built-in names - -unitCon_RDR, unitTyCon_RDR, nilCon_RDR, listTyCon_RDR :: RdrName -tupleCon_RDR, tupleTyCon_RDR :: Int -> RdrName -ubxTupleCon_RDR, ubxTupleTyCon_RDR :: Int -> RdrName - -unitCon_RDR - | opt_NoImplicitPrelude = mkSrcUnqual dataName unitName - | otherwise = mkPreludeQual dataName pRELUDE_Name unitName - -unitTyCon_RDR - | opt_NoImplicitPrelude = mkSrcUnqual tcName unitName - | otherwise = mkPreludeQual tcName pRELUDE_Name unitName - -nilCon_RDR - | opt_NoImplicitPrelude = mkSrcUnqual dataName listName - | otherwise = mkPreludeQual dataName pRELUDE_Name listName - -listTyCon_RDR - | opt_NoImplicitPrelude = mkSrcUnqual tcName listName - | otherwise = mkPreludeQual tcName pRELUDE_Name listName - -funTyCon_RDR - | opt_NoImplicitPrelude = mkSrcUnqual tcName funName - | otherwise = mkPreludeQual tcName pRELUDE_Name funName - -tupleCon_RDR arity - | opt_NoImplicitPrelude = mkSrcUnqual dataName (snd (mkTupNameStr arity)) - | otherwise = mkPreludeQual dataName pRELUDE_Name - (snd (mkTupNameStr arity)) - -tupleTyCon_RDR arity - | opt_NoImplicitPrelude = mkSrcUnqual tcName (snd (mkTupNameStr arity)) - | otherwise = mkPreludeQual tcName pRELUDE_Name - (snd (mkTupNameStr arity)) - - -ubxTupleCon_RDR arity - | opt_NoImplicitPrelude = mkSrcUnqual dataName (snd (mkUbxTupNameStr arity)) - | otherwise = mkPreludeQual dataName pRELUDE_Name - (snd (mkUbxTupNameStr arity)) - -ubxTupleTyCon_RDR arity - | opt_NoImplicitPrelude = mkSrcUnqual tcName (snd (mkUbxTupNameStr arity)) - | otherwise = mkPreludeQual tcName pRELUDE_Name - (snd (mkUbxTupNameStr arity)) - -unitName = SLIT("()") -funName = SLIT("(->)") -listName = SLIT("[]") - -asName = SLIT("as") -hidingName = SLIT("hiding") -qualifiedName = SLIT("qualified") -forallName = SLIT("forall") -exportName = SLIT("export") -labelName = SLIT("label") -dynamicName = SLIT("dynamic") -unsafeName = SLIT("unsafe") -stdcallName = SLIT("stdcall") -ccallName = SLIT("ccall") - -as_var_RDR = mkSrcUnqual varName asName -hiding_var_RDR = mkSrcUnqual varName hidingName -qualified_var_RDR = mkSrcUnqual varName qualifiedName -forall_var_RDR = mkSrcUnqual varName forallName -export_var_RDR = mkSrcUnqual varName exportName -label_var_RDR = mkSrcUnqual varName labelName -dynamic_var_RDR = mkSrcUnqual varName dynamicName -unsafe_var_RDR = mkSrcUnqual varName unsafeName -stdcall_var_RDR = mkSrcUnqual varName stdcallName -ccall_var_RDR = mkSrcUnqual varName ccallName - -as_tyvar_RDR = mkSrcUnqual tvName asName -hiding_tyvar_RDR = mkSrcUnqual tvName hidingName -qualified_tyvar_RDR = mkSrcUnqual tvName qualifiedName -export_tyvar_RDR = mkSrcUnqual tvName exportName -label_tyvar_RDR = mkSrcUnqual tvName labelName -dynamic_tyvar_RDR = mkSrcUnqual tvName dynamicName -unsafe_tyvar_RDR = mkSrcUnqual tvName unsafeName -stdcall_tyvar_RDR = mkSrcUnqual tvName stdcallName -ccall_tyvar_RDR = mkSrcUnqual tvName ccallName - -minus_RDR = mkSrcUnqual varName SLIT("-") -pling_RDR = mkSrcUnqual varName SLIT("!") -dot_RDR = mkSrcUnqual varName SLIT(".") - -plus_RDR = mkSrcUnqual varName SLIT("+") +-- --------------------------------------------------------------------------- +-- Make the export list for an interface + +mkIfaceExports :: [RdrNameTyClDecl] -> [RdrAvailInfo] +mkIfaceExports decls = map getExport decls + where getExport d = case d of + TyData{} -> tc_export + ClassDecl{} -> tc_export + _other -> var_export + where + tc_export = AvailTC (rdrNameOcc (tcdName d)) + (map (rdrNameOcc.fst) (tyClDeclNames d)) + var_export = Avail (rdrNameOcc (tcdName d)) \end{code}