X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fparser%2FRdrHsSyn.lhs;h=781b085fe15881ce9c0dc88042a341dcc555bf80;hb=423d477bfecd490de1449c59325c8776f91d7aac;hp=01df302a0e4ed1578b0bd0a9e9a773215823b91d;hpb=298a8b8129dd3ef637eb18d5d83d7a752d845598;p=ghc-hetmet.git diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs index 01df302..781b085 100644 --- a/ghc/compiler/parser/RdrHsSyn.lhs +++ b/ghc/compiler/parser/RdrHsSyn.lhs @@ -51,23 +51,22 @@ module RdrHsSyn ( import HsSyn -- Lots of it import IfaceType import HscTypes ( ModIface(..), emptyModIface, mkIfaceVerCache ) -import IfaceSyn ( IfaceDecl(..), IfaceIdInfo(..) ) +import IfaceSyn ( IfaceDecl(..), IfaceIdInfo(..), IfaceConDecl(..), IfaceConDecls(..) ) import RdrName ( RdrName, isRdrTyVar, mkUnqual, rdrNameOcc, isRdrTyVar, isRdrDataCon, isUnqual, getRdrName, isQual, setRdrNameSpace, rdrNameModule ) import BasicTypes ( RecFlag(..), mapIPName, maxPrecedence, initialVersion ) import Lexer ( P, failSpanMsgP ) +import Kind ( liftedTypeKind ) import HscTypes ( GenAvailInfo(..) ) import TysWiredIn ( unitTyCon ) import ForeignCall ( CCallConv, Safety, CCallTarget(..), CExportSpec(..), - DNCallSpec(..), DNKind(..)) + DNCallSpec(..), DNKind(..), CLabelString ) import OccName ( OccName, srcDataName, varName, isDataOcc, isTcOcc, occNameUserString, isValOcc ) -import BasicTypes ( initialVersion ) -import TyCon ( DataConDetails(..) ) +import BasicTypes ( initialVersion, StrictnessMark(..) ) import Module ( ModuleName ) import SrcLoc -import CStrings ( CLabelString ) import CmdLineOpts ( opt_InPackage ) import OrdList ( OrdList, fromOL ) import Bag ( Bag, emptyBag, snocBag, consBag, foldrBag ) @@ -113,10 +112,11 @@ extract_ty (HsListTy ty) acc = extract_lty ty acc extract_ty (HsPArrTy ty) acc = extract_lty ty acc extract_ty (HsTupleTy _ tys) acc = foldr extract_lty acc tys extract_ty (HsFunTy ty1 ty2) acc = extract_lty ty1 (extract_lty ty2 acc) -extract_ty (HsPredTy p) acc = extract_pred (unLoc p) acc +extract_ty (HsPredTy p) acc = extract_pred p acc extract_ty (HsOpTy ty1 nam ty2) acc = extract_lty ty1 (extract_lty ty2 acc) extract_ty (HsParTy ty) acc = extract_lty ty acc extract_ty (HsNumTy num) acc = acc +extract_ty (HsSpliceTy _) acc = acc -- Type splices mention no type variables extract_ty (HsKindSig ty k) acc = extract_lty ty acc extract_ty (HsForAllTy exp [] cx ty) acc = extract_lctxt cx (extract_lty ty acc) extract_ty (HsForAllTy exp tvs cx ty) @@ -240,11 +240,11 @@ hsIfaceDecl (TyClD decl@(TySynonym {})) ifVrcs = [] } hsIfaceDecl (TyClD decl@(TyData {})) - = IfaceData { ifND = tcdND decl, - ifName = rdrNameOcc (tcdName decl), + = IfaceData { ifName = rdrNameOcc (tcdName decl), ifTyVars = hsIfaceTvs (tcdTyVars decl), ifCtxt = hsIfaceCtxt (unLoc (tcdCtxt decl)), - ifCons = Unknown, ifRec = NonRecursive, + ifCons = hsIfaceCons (tcdND decl) (tcdCons decl), + ifRec = NonRecursive, ifVrcs = [], ifGeneric = False } -- I'm not sure that [] is right for ifVrcs, but -- since we don't use them I'm not going to fiddle @@ -259,6 +259,39 @@ hsIfaceDecl (TyClD decl@(ClassDecl {})) hsIfaceDecl decl = pprPanic "hsIfaceDecl" (ppr decl) +hsIfaceCons :: NewOrData -> [LConDecl RdrName] -> IfaceConDecls +hsIfaceCons DataType [] -- data T a, meaning "constructors unspecified", + = IfAbstractTyCon -- not "no constructors" + +hsIfaceCons DataType cons -- data type + = IfDataTyCon (map (hsIfaceCon . unLoc) cons) + +hsIfaceCons NewType [con] -- newtype + = IfNewTyCon (hsIfaceCon (unLoc con)) + + +hsIfaceCon :: ConDecl RdrName -> IfaceConDecl +hsIfaceCon (ConDecl lname ex_tvs ex_ctxt details) + = IfaceConDecl (get_occ lname) is_infix + (hsIfaceTvs ex_tvs) + (hsIfaceCtxt (unLoc ex_ctxt)) + (map (hsIfaceLType . getBangType . unLoc) args) + (map (hsStrictMark . getBangStrictness . unLoc) args) + flds + where + (is_infix, args, flds) = case details of + PrefixCon args -> (False, args, []) + InfixCon a1 a2 -> (True, [a1,a2], []) + RecCon fs -> (False, map snd fs, map (get_occ . fst) fs) + get_occ lname = rdrNameOcc (unLoc lname) + +hsStrictMark :: HsBang -> StrictnessMark +-- Warning: in source files the {-# UNPACK #-} pragma (HsUnbox) is a request +-- but in an hi-boot file it's interpreted as the Truth! +hsStrictMark HsNoBang = NotMarkedStrict +hsStrictMark HsStrict = MarkedStrict +hsStrictMark HsUnbox = MarkedUnboxed + hsIfaceName rdr_name -- Qualify unqualifed occurrences -- with the module name | isUnqual rdr_name = LocalTop (rdrNameOcc rdr_name) @@ -285,9 +318,10 @@ hsIfaceType (HsPArrTy t) = IfaceTyConApp IfacePArrTc [hsIfaceLType t] hsIfaceType (HsTupleTy bx ts) = IfaceTyConApp (IfaceTupTc bx (length ts)) (hsIfaceLTypes ts) hsIfaceType (HsOpTy t1 tc t2) = hs_tc_app (HsTyVar (unLoc tc)) (hsIfaceLTypes [t1, t2]) hsIfaceType (HsParTy t) = hsIfaceLType t -hsIfaceType (HsNumTy n) = panic "hsIfaceType:HsNum" -hsIfaceType (HsPredTy p) = IfacePredTy (hsIfaceLPred p) +hsIfaceType (HsPredTy p) = IfacePredTy (hsIfacePred p) hsIfaceType (HsKindSig t _) = hsIfaceLType t +hsIfaceType (HsNumTy n) = panic "hsIfaceType:HsNum" +hsIfaceType (HsSpliceTy _) = panic "hsIfaceType:HsSpliceTy" ----------- hsIfaceLTypes tys = map (hsIfaceType.unLoc) tys @@ -316,8 +350,8 @@ hs_tc_app ty args = foldl IfaceAppTy (hsIfaceType ty) args hsIfaceTvs tvs = map (hsIfaceTv.unLoc) tvs ----------- -hsIfaceTv (UserTyVar n) = (rdrNameOcc n, IfaceLiftedTypeKind) -hsIfaceTv (KindedTyVar n k) = (rdrNameOcc n, toIfaceKind k) +hsIfaceTv (UserTyVar n) = (rdrNameOcc n, liftedTypeKind) +hsIfaceTv (KindedTyVar n k) = (rdrNameOcc n, k) ----------- hsIfaceFDs :: [([RdrName], [RdrName])] -> [([OccName], [OccName])] @@ -585,7 +619,7 @@ checkPred :: LHsType RdrName -> P (LHsPred 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 (L spn (HsPredTy (L _ (HsIParam n ty))) ) +checkPred (L spn (HsPredTy (HsIParam n ty))) = return (L spn (HsIParam n ty)) checkPred (L spn ty) = check spn ty [] @@ -601,8 +635,8 @@ checkPred (L spn ty) checkDictTy :: LHsType RdrName -> P (LHsType RdrName) checkDictTy (L spn ty) = check ty [] where - check (HsTyVar t) args@(_:_) | not (isRdrTyVar t) - = return (L spn (HsPredTy (L spn (HsClassP t args)))) + check (HsTyVar t) args | not (isRdrTyVar t) + = return (L spn (HsPredTy (HsClassP t args))) check (HsAppTy l r) args = check (unLoc l) (r:args) check (HsParTy t) args = check (unLoc t) args check _ _ = parseError spn "Malformed context in instance header" @@ -714,8 +748,6 @@ checkAPat loc e = case e of HsType ty -> return (TypePat ty) _ -> patFail loc -checkAPat loc _ = patFail loc - checkPatField :: (Located RdrName, LHsExpr RdrName) -> P (Located RdrName, LPat RdrName) checkPatField (n,e) = do p <- checkLPat e