\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
-----------------------------------------------------------------------------
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)
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
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
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
-> 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
---------------------------------------------------------------------------
checkPrec :: Integer -> P ()
checkPrec i | 0 <= i && i <= 9 = returnP ()
- | otherwise = parseError "precedence out of range"
+ | otherwise = parseError "Precedence out of range"
mkRecConstrOrUpdate
:: RdrNameHsExpr
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
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
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}
projects / ghc-hetmet.git / blobdiff