X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fparser%2FParseUtil.lhs;h=3bec98e035610332f9465a4b32af0414f705a1e5;hb=2205f0ceeb65d8acb7db953bf4fd2ad673dc55ee;hp=6d45c0d7b139a95224c535c75e0bb8a64be17d00;hpb=61bfd5dd3b9d70404d6f93c030a9bb1c402b9d31;p=ghc-hetmet.git diff --git a/ghc/compiler/parser/ParseUtil.lhs b/ghc/compiler/parser/ParseUtil.lhs index 6d45c0d..3bec98e 100644 --- a/ghc/compiler/parser/ParseUtil.lhs +++ b/ghc/compiler/parser/ParseUtil.lhs @@ -5,43 +5,55 @@ \begin{code} module ParseUtil ( - parseError -- String -> Pa + parseError -- String -> Pa , mkVanillaCon, mkRecCon, - , mkRecConstrOrUpdate -- HsExp -> [HsFieldUpdate] -> P HsExp + , mkRecConstrOrUpdate -- HsExp -> [HsFieldUpdate] -> P HsExp , groupBindings - , mkExtName -- RdrName -> ExtName - - , checkPrec -- String -> P String - , checkContext -- HsType -> P HsContext - , checkInstType -- HsType -> P HsType - , checkDataHeader -- HsQualType -> P (HsContext,HsName,[HsName]) - , checkSimple -- HsType -> [HsName] -> P ((HsName,[HsName])) - , 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 + , 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 HscTypes ( RdrAvailInfo, GenAvailInfo(..) ) import HsSyn -- Lots of it +import ForeignCall ( CCallConv, Safety, CCallTarget(..), CExportSpec(..), + DNCallSpec(..)) import SrcLoc -import RdrHsSyn ( RdrBinding(..), - RdrNameHsType, RdrNameBangType, RdrNameContext, - RdrNameHsTyVar, RdrNamePat, RdrNameHsExpr, RdrNameGRHSs, - RdrNameHsRecordBinds, RdrNameMonoBinds, RdrNameConDetails, - mkNPlusKPat - ) +import RdrHsSyn import RdrName import PrelNames ( unitTyCon_RDR ) -import OccName ( dataName, varName, tcClsName, +import OccName ( dataName, varName, tcClsName, isDataOcc, occNameSpace, setOccNameSpace, occNameUserString ) import CStrings ( CLabelString ) -import FastString ( unpackFS ) +import FastString import Outputable ----------------------------------------------------------------------------- @@ -81,7 +93,7 @@ tyConToDataCon tc | occNameSpace tc_occ == tcClsName = returnP (setRdrNameOcc tc (setOccNameSpace tc_occ dataName)) | otherwise - = parseError (showSDoc (text "not a constructor:" <+> quotes (ppr tc))) + = parseError (showSDoc (text "Not a constructor:" <+> quotes (ppr tc))) where tc_occ = rdrNameOcc tc @@ -96,57 +108,72 @@ checkInstType t 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 (HsTupleTy _ ts) - = mapP (\t -> checkPred t []) ts `thenP` \ps -> - returnP ps -checkContext (HsTyVar 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 - = checkPred t [] `thenP` \p -> + = checkPred t `thenP` \p -> returnP [p] -checkPred :: RdrNameHsType -> [RdrNameHsType] - -> P (HsPred RdrName) -checkPred (HsTyVar t) args@(_:_) | not (isRdrTyVar t) - = returnP (HsClassP t args) -checkPred (HsAppTy l r) args = checkPred l (r:args) -checkPred (HsPredTy (HsIParam n ty)) [] = returnP (HsIParam n ty) -checkPred _ _ = parseError "Illegal class assertion" +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" --- Put more comments! --- Checks that the lhs of a datatype declaration --- is of the form Context => T a b ... z -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) - --- Checks the type part of the lhs of a datatype declaration -checkSimple :: RdrNameHsType -> [RdrName] -> P ((RdrName,[RdrName])) -checkSimple (HsAppTy l (HsTyVar a)) xs | isRdrTyVar a - = checkSimple l (a:xs) -checkSimple (HsTyVar tycon) xs | not (isRdrTyVar tycon) = returnP (tycon,xs) - -checkSimple (HsOpTy (HsTyVar t1) tycon (HsTyVar t2)) [] - | not (isRdrTyVar tycon) && isRdrTyVar t1 && isRdrTyVar t2 - = returnP (tycon,[t1,t2]) - -checkSimple t _ = parseError "Illegal left hand side in data/newtype declaration" --------------------------------------------------------------------------- -- Checking statements in a do-expression @@ -182,7 +209,7 @@ checkPat e [] = case e of EWildPat -> returnP WildPatIn HsVar x -> returnP (VarPatIn x) HsLit l -> returnP (LitPatIn l) - HsOverLit l -> returnP (NPatIn 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 -> @@ -195,21 +222,31 @@ checkPat e [] = case e of in returnP (SigPatIn e t') + -- 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 SLIT("+") -- Hack + 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 HsPar e -> checkPat e [] `thenP` (returnP . ParPatIn) 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) @@ -218,7 +255,7 @@ checkPat e [] = case e of returnP (RecPatIn c fs) -- Generics HsType ty -> returnP (TypePatIn ty) - _ -> patFail + _ -> patFail checkPat _ _ = patFail @@ -274,7 +311,7 @@ isFunLhs (OpApp l (HsVar op) fix r) es | not (isRdrDataCon op) 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 --------------------------------------------------------------------------- @@ -282,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 @@ -296,15 +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; 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 = _PK_ (occNameUserString (rdrNameOcc rdrNm)) +mkExtName rdrNm = mkFastString (occNameUserString (rdrNameOcc rdrNm)) ----------------------------------------------------------------------------- -- group function bindings into equation groups @@ -334,4 +463,18 @@ groupBindings binds = group Nothing binds = case bind of RdrValBinding b@(FunMonoBind _ _ _ _) -> group (Just b) binds other -> bind `RdrAndBindings` group Nothing binds + +-- --------------------------------------------------------------------------- +-- 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}