X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fparser%2FRdrHsSyn.lhs;h=6fb6e86d6874e77a404d34e78b1ed37d16cf3bfe;hb=252abd9e355fe12e8f6f1e0192542a0df6ddccac;hp=45b015b0a936698cd213d5f8e1ee872929f28668;hpb=51f116efc047bf352fd2f29e167208deffa05895;p=ghc-hetmet.git diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs index 45b015b..6fb6e86 100644 --- a/ghc/compiler/parser/RdrHsSyn.lhs +++ b/ghc/compiler/parser/RdrHsSyn.lhs @@ -51,7 +51,7 @@ module RdrHsSyn ( import HsSyn -- Lots of it import IfaceType import HscTypes ( ModIface(..), emptyModIface, mkIfaceVerCache ) -import IfaceSyn ( IfaceDecl(..), IfaceIdInfo(..), IfaceConDecl(..) ) +import IfaceSyn ( IfaceDecl(..), IfaceIdInfo(..), IfaceConDecl(..), IfaceConDecls(..) ) import RdrName ( RdrName, isRdrTyVar, mkUnqual, rdrNameOcc, isRdrTyVar, isRdrDataCon, isUnqual, getRdrName, isQual, setRdrNameSpace, rdrNameModule ) @@ -61,14 +61,12 @@ 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, StrictnessMark(..) ) -import TyCon ( DataConDetails(..) ) import Module ( ModuleName ) import SrcLoc -import CStrings ( CLabelString ) import CmdLineOpts ( opt_InPackage ) import OrdList ( OrdList, fromOL ) import Bag ( Bag, emptyBag, snocBag, consBag, foldrBag ) @@ -114,7 +112,7 @@ 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 @@ -242,11 +240,10 @@ 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 = hsIfaceCons (tcdCons decl), + ifCons = hsIfaceCons (tcdND decl) (tcdCons decl), ifRec = NonRecursive, ifVrcs = [], ifGeneric = False } -- I'm not sure that [] is right for ifVrcs, but @@ -262,26 +259,30 @@ hsIfaceDecl (TyClD decl@(ClassDecl {})) hsIfaceDecl decl = pprPanic "hsIfaceDecl" (ppr decl) -hsIfaceCons :: [LConDecl RdrName] -> DataConDetails IfaceConDecl -hsIfaceCons cons - | null cons -- data T a, meaning "constructors unspecified", not "no constructors" - = Unknown - | otherwise -- data T a = C1 | C2 - = DataCons (map (hsIfaceCon . unLoc) cons) +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) + = 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 - (args, flds) = case details of - PrefixCon args -> (args, []) - InfixCon a1 a2 -> ([a1,a2], []) - RecCon fs -> (map snd fs, map (get_occ . fst) fs) + (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 @@ -317,7 +318,7 @@ 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 (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" @@ -618,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 [] @@ -634,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" @@ -761,17 +762,16 @@ patFail loc = parseError loc "Parse error in pattern" checkValDef :: LHsExpr RdrName -> Maybe (LHsType RdrName) - -> GRHSs RdrName + -> Located (GRHSs RdrName) -> P (HsBind RdrName) -checkValDef lhs opt_sig grhss +checkValDef lhs opt_sig (L rhs_span grhss) | Just (f,inf,es) <- isFunLhs lhs [] = if isQual (unLoc f) then parseError (getLoc f) ("Qualified name in function definition: " ++ showRdrName (unLoc f)) else do ps <- checkPatterns es - return (FunBind f inf [L (getLoc f) (Match ps opt_sig grhss)]) - -- TODO: span is wrong + return (FunBind f inf [L rhs_span (Match ps opt_sig grhss)]) | otherwise = do lhs <- checkPattern lhs return (PatBind lhs grhss)