From 72264dbcb05c7045dff28aa88b55634fa6c1ddf0 Mon Sep 17 00:00:00 2001 From: Manuel M T Chakravarty Date: Fri, 15 Sep 2006 20:49:30 +0000 Subject: [PATCH] Parser support for assoc synonyms Fri Jul 28 21:52:46 EDT 2006 Manuel M T Chakravarty * Parser support for assoc synonyms --- compiler/hsSyn/HsDecls.lhs | 66 +++++++++++++++++++++++++------- compiler/main/HscStats.lhs | 5 ++- compiler/parser/Lexer.x | 3 ++ compiler/parser/Parser.y.pp | 85 ++++++++++++++++++++++++++++++------------ compiler/parser/RdrHsSyn.lhs | 50 +++++++++++++++++-------- 5 files changed, 155 insertions(+), 54 deletions(-) diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs index 070079e..f2bf9d3 100644 --- a/compiler/hsSyn/HsDecls.lhs +++ b/compiler/hsSyn/HsDecls.lhs @@ -18,7 +18,7 @@ module HsDecls ( DeprecDecl(..), LDeprecDecl, HsGroup(..), emptyRdrGroup, emptyRnGroup, appendGroups, tcdName, tyClDeclNames, tyClDeclTyVars, - isClassDecl, isSynDecl, isDataDecl, + isClassDecl, isTFunDecl, isSynDecl, isTEqnDecl, isDataDecl, countTyClDecls, conDetailsTys, instDeclATs, @@ -359,8 +359,15 @@ data TyClDecl name -- are non-empty for the newtype-deriving case } + | TyFunction {tcdLName :: Located name, -- type constructor + tcdTyVars :: [LHsTyVarBndr name], -- type variables + tcdIso :: Bool, -- injective type? + tcdKindSig:: Maybe Kind -- result kind + } + | TySynonym { tcdLName :: Located name, -- type constructor tcdTyVars :: [LHsTyVarBndr name], -- type variables + tcdTyPats :: Maybe [LHsType name], -- Type patterns tcdSynRhs :: LHsType name -- synonym expansion } @@ -384,10 +391,20 @@ data NewOrData Simple classifiers \begin{code} -isDataDecl, isSynDecl, isClassDecl :: TyClDecl name -> Bool +isTFunDecl, isDataDecl, isSynDecl, isTEqnDecl, isClassDecl :: + TyClDecl name -> Bool + +-- type function kind signature +isTFunDecl (TyFunction {}) = True +isTFunDecl other = False + +-- vanilla Haskell type synonym +isSynDecl (TySynonym {tcdTyPats = Nothing}) = True +isSynDecl other = False -isSynDecl (TySynonym {}) = True -isSynDecl other = False +-- type equation (of a type function) +isTEqnDecl (TySynonym {tcdTyPats = Just _}) = True +isTEqnDecl other = False isDataDecl (TyData {}) = True isDataDecl other = False @@ -408,8 +425,11 @@ tyClDeclNames :: Eq name => TyClDecl name -> [Located name] -- For record fields, the first one counts as the SrcLoc -- We use the equality to filter out duplicate field names -tyClDeclNames (TySynonym {tcdLName = name}) = [name] -tyClDeclNames (ForeignType {tcdLName = name}) = [name] +tyClDeclNames (TyFunction {tcdLName = name}) = [name] +tyClDeclNames (TySynonym {tcdLName = name, + tcdTyPats= Nothing}) = [name] +tyClDeclNames (TySynonym {} ) = [] -- type equation +tyClDeclNames (ForeignType {tcdLName = name}) = [name] tyClDeclNames (ClassDecl {tcdLName = cls_name, tcdSigs = sigs, tcdATs = ats}) = cls_name : @@ -418,18 +438,22 @@ tyClDeclNames (ClassDecl {tcdLName = cls_name, tcdSigs = sigs, tcdATs = ats}) tyClDeclNames (TyData {tcdLName = tc_name, tcdCons = cons}) = tc_name : conDeclsNames (map unLoc cons) -tyClDeclTyVars (TySynonym {tcdTyVars = tvs}) = tvs -tyClDeclTyVars (TyData {tcdTyVars = tvs}) = tvs -tyClDeclTyVars (ClassDecl {tcdTyVars = tvs}) = tvs -tyClDeclTyVars (ForeignType {}) = [] +tyClDeclTyVars (TyFunction {tcdTyVars = tvs}) = tvs +tyClDeclTyVars (TySynonym {tcdTyVars = tvs}) = tvs +tyClDeclTyVars (TyData {tcdTyVars = tvs}) = tvs +tyClDeclTyVars (ClassDecl {tcdTyVars = tvs}) = tvs +tyClDeclTyVars (ForeignType {}) = [] \end{code} \begin{code} -countTyClDecls :: [TyClDecl name] -> (Int, Int, Int, Int) - -- class, data, newtype, synonym decls +countTyClDecls :: [TyClDecl name] -> (Int, Int, Int, Int, Int, Int) + -- class, synonym decls, type function signatures, + -- type function equations, data, newtype countTyClDecls decls = (count isClassDecl decls, count isSynDecl decls, + count isTFunDecl decls, + count isTEqnDecl decls, count isDataTy decls, count isNewTy decls) where @@ -447,8 +471,22 @@ instance OutputableBndr name ppr (ForeignType {tcdLName = ltycon}) = hsep [ptext SLIT("foreign import type dotnet"), ppr ltycon] - ppr (TySynonym {tcdLName = ltycon, tcdTyVars = tyvars, tcdSynRhs = mono_ty}) - = hang (ptext SLIT("type") <+> pp_decl_head [] ltycon tyvars Nothing <+> equals) + ppr (TyFunction {tcdLName = ltycon, tcdTyVars = tyvars, tcdIso = iso, + tcdKindSig = mb_sig}) + = typeMaybeIso <+> pp_decl_head [] ltycon tyvars Nothing <+> + ppr_sig mb_sig + where + typeMaybeIso = if iso + then ptext SLIT("type iso") + else ptext SLIT("type") + + ppr_sig Nothing = empty + ppr_sig (Just kind) = dcolon <+> pprKind kind + + ppr (TySynonym {tcdLName = ltycon, tcdTyVars = tyvars, tcdTyPats = typats, + tcdSynRhs = mono_ty}) + = hang (ptext SLIT("type") <+> pp_decl_head [] ltycon tyvars typats <+> + equals) 4 (ppr mono_ty) ppr (TyData {tcdND = new_or_data, tcdCtxt = context, tcdLName = ltycon, diff --git a/compiler/main/HscStats.lhs b/compiler/main/HscStats.lhs index e4e8ac5..a750ad8 100644 --- a/compiler/main/HscStats.lhs +++ b/compiler/main/HscStats.lhs @@ -38,6 +38,8 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _)) ("FixityDecls ", fixity_sigs), ("DefaultDecls ", default_ds), ("TypeDecls ", type_ds), + ("TypeFunDecls ", type_fun_ds), + ("TypeEquations ", type_equs), ("DataDecls ", data_ds), ("NewTypeDecls ", newt_ds), ("DataConstrs ", data_constrs), @@ -73,7 +75,8 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _)) -- in class decls. ToDo tycl_decls = [d | TyClD d <- decls] - (class_ds, type_ds, data_ds, newt_ds) = countTyClDecls tycl_decls + (class_ds, type_ds, type_fun_ds, type_equs, data_ds, newt_ds) = + countTyClDecls tycl_decls inst_decls = [d | InstD d <- decls] inst_ds = length inst_decls diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index 0b02f41..aed9cfb 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -376,6 +376,7 @@ data Token | ITccallconv | ITdotnet | ITmdo + | ITiso -- Pragmas | ITinline_prag Bool -- True <=> INLINE, False <=> NOINLINE @@ -499,6 +500,7 @@ isSpecial ITunsafe = True isSpecial ITccallconv = True isSpecial ITstdcallconv = True isSpecial ITmdo = True +isSpecial ITiso = True isSpecial _ = False -- the bitmap provided as the third component indicates whether the @@ -539,6 +541,7 @@ reservedWordsFM = listToUFM $ ( "forall", ITforall, bit tvBit), ( "mdo", ITmdo, bit glaExtsBit), + ( "iso", ITiso, bit glaExtsBit), ( "foreign", ITforeign, bit ffiBit), ( "export", ITexport, bit ffiBit), diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index da00825..7b9786f 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -113,6 +113,7 @@ and LL. Each of these macros can be thought of as having type They each add a SrcSpan to their argument. L0 adds 'noSrcSpan', used for empty productions + -- This doesn't seem to work anymore -=chak L1 for a production with a single token on the lhs. Grabs the SrcSpan from that token. @@ -175,7 +176,7 @@ incorrect. 'where' { L _ ITwhere } '_scc_' { L _ ITscc } -- ToDo: remove - 'forall' { L _ ITforall } -- GHC extension keywords + 'forall' { L _ ITforall } -- GHC extension keywords 'foreign' { L _ ITforeign } 'export' { L _ ITexport } 'label' { L _ ITlabel } @@ -184,6 +185,7 @@ incorrect. 'threadsafe' { L _ ITthreadsafe } 'unsafe' { L _ ITunsafe } 'mdo' { L _ ITmdo } + 'iso' { L _ ITiso } 'stdcall' { L _ ITstdcallconv } 'ccall' { L _ ITccallconv } 'dotnet' { L _ ITdotnet } @@ -466,7 +468,7 @@ cl_decl :: { LTyClDecl RdrName } {% do { let { (binds, sigs, ats) = cvBindsAndSigs (unLoc $4) ; (ctxt, tc, tvs, Just tparms) = unLoc $2} - ; checkTyVars tparms + ; checkTyVars tparms False -- only type vars allowed ; return $ L (comb4 $1 $2 $3 $4) (mkClassDecl (ctxt, tc, tvs) (unLoc $3) sigs binds ats) } } @@ -474,27 +476,61 @@ cl_decl :: { LTyClDecl RdrName } -- Type declarations -- ty_decl :: { LTyClDecl RdrName } - : 'type' type '=' ctype - -- Note type on the left of the '='; this allows - -- infix type constructors to be declared + -- type function signature and equations (w/ type synonyms as special + -- case); we need to handle all this in one rule to avoid a large + -- number of shift/reduce conflicts (due to the generality of `type') + : 'type' opt_iso type kind_or_ctype + -- + -- Note the use of type for the head; this allows + -- infix type constructors to be declared and type + -- patterns for type function equations -- - -- Note ctype, not sigtype, on the right - -- We allow an explicit for-all but we don't insert one - -- in type Foo a = (b,b) - -- Instead we just say b is out of scope - {% do { (tc,tvs) <- checkSynHdr $2 - ; return (LL (TySynonym tc tvs $4)) } } - + -- We have that `typats :: Maybe [LHsType name]' is `Nothing' + -- (in the second case alternative) when all arguments are + -- variables (and we thus have a vanilla type synonym + -- declaration); otherwise, it contains all arguments as type + -- patterns. + -- + {% case $4 of + Left kind -> + do { (tc, tvs, _) <- checkSynHdr $3 False + ; return (L (comb3 $1 $3 kind) + (TyFunction tc tvs $2 (unLoc kind))) + } + Right ty -> + do { (tc, tvs, typats) <- checkSynHdr $3 True + ; return (L (comb2 $1 ty) + (TySynonym tc tvs typats ty)) } + } + + -- data type or newtype declaration | data_or_newtype tycl_hdr constrs deriving { L (comb4 $1 $2 $3 $4) -- We need the location on tycl_hdr - -- in case constrs and deriving are both empty - (mkTyData (unLoc $1) (unLoc $2) Nothing (reverse (unLoc $3)) (unLoc $4)) } + -- in case constrs and deriving are + -- both empty + (mkTyData (unLoc $1) (unLoc $2) Nothing + (reverse (unLoc $3)) (unLoc $4)) } + -- GADT declaration | data_or_newtype tycl_hdr opt_kind_sig 'where' gadt_constrlist deriving { L (comb4 $1 $2 $4 $5) - (mkTyData (unLoc $1) (unLoc $2) $3 (reverse (unLoc $5)) (unLoc $6)) } + (mkTyData (unLoc $1) (unLoc $2) $3 + (reverse (unLoc $5)) (unLoc $6)) } + +opt_iso :: { Bool } + : { False } + | 'iso' { True } + +kind_or_ctype :: { Either (Located (Maybe Kind)) (LHsType RdrName) } + : { Left (noLoc Nothing) } + | '::' kind { Left (LL (Just (unLoc $2))) } + | '=' ctype { Right (LL (unLoc $2)) } + -- Note ctype, not sigtype, on the right of '=' + -- We allow an explicit for-all but we don't insert one + -- in type Foo a = (b,b) + -- Instead we just say b is out of scope data_or_newtype :: { Located NewOrData } : 'data' { L1 DataType } @@ -502,7 +538,7 @@ data_or_newtype :: { Located NewOrData } opt_kind_sig :: { Maybe Kind } : { Nothing } - | '::' kind { Just $2 } + | '::' kind { Just (unLoc $2) } -- tycl_hdr parses the header of a type decl, -- which takes the form @@ -719,7 +755,7 @@ atype :: { LHsType RdrName } | '[' ctype ']' { LL $ HsListTy $2 } | '[:' ctype ':]' { LL $ HsPArrTy $2 } | '(' ctype ')' { LL $ HsParTy $2 } - | '(' ctype '::' kind ')' { LL $ HsKindSig $2 $4 } + | '(' ctype '::' kind ')' { LL $ HsKindSig $2 (unLoc $4) } -- Generics | INTEGER { L1 (HsNumTy (getINTEGER $1)) } @@ -748,7 +784,8 @@ tv_bndrs :: { [LHsTyVarBndr RdrName] } tv_bndr :: { LHsTyVarBndr RdrName } : tyvar { L1 (UserTyVar (unLoc $1)) } - | '(' tyvar '::' kind ')' { LL (KindedTyVar (unLoc $2) $4) } + | '(' tyvar '::' kind ')' { LL (KindedTyVar (unLoc $2) + (unLoc $4)) } fds :: { Located [Located ([RdrName], [RdrName])] } : {- empty -} { noLoc [] } @@ -769,14 +806,14 @@ varids0 :: { Located [RdrName] } ----------------------------------------------------------------------------- -- Kinds -kind :: { Kind } +kind :: { Located Kind } : akind { $1 } - | akind '->' kind { mkArrowKind $1 $3 } + | akind '->' kind { LL (mkArrowKind (unLoc $1) (unLoc $3)) } -akind :: { Kind } - : '*' { liftedTypeKind } - | '!' { unliftedTypeKind } - | '(' kind ')' { $2 } +akind :: { Located Kind } + : '*' { L1 liftedTypeKind } + | '!' { L1 unliftedTypeKind } + | '(' kind ')' { LL (unLoc $2) } ----------------------------------------------------------------------------- diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index 59651a4..b0cf2cf 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -36,8 +36,8 @@ module RdrHsSyn ( checkContext, -- HsType -> P HsContext checkPred, -- HsType -> P HsPred checkTyClHdr, -- LHsContext RdrName -> LHsType RdrName -> P (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName]) - checkTyVars, -- [LHsType RdrName] -> P () - checkSynHdr, -- LHsType RdrName -> P (Located RdrName, [LHsTyVarBndr RdrName]) + checkTyVars, -- [LHsType RdrName] -> Bool -> P () + checkSynHdr, -- LHsType RdrName -> P (Located RdrName, [LHsTyVarBndr RdrName], Maybe [LHsType RdrName]) checkTopTyClD, -- LTyClDecl RdrName -> P (HsDecl RdrName) checkInstType, -- HsType -> P HsType checkPattern, -- HsExp -> P HsPat @@ -377,25 +377,45 @@ checkInstType (L l t) ty -> do dict_ty <- checkDictTy (L l ty) return (L l (HsForAllTy Implicit [] (noLoc []) dict_ty)) --- Check that the given list of type parameters are all type variables --- (possibly with a kind signature). +-- Check whether the given list of type parameters are all type variables +-- (possibly with a kind signature). If the second argument is `False', we +-- only type variables are allowed and we raise an error on encountering a +-- non-variable; otherwise, we return the entire list parameters iff at least +-- one is not a variable. -- -checkTyVars :: [LHsType RdrName] -> P () -checkTyVars tvs = mapM_ chk tvs +checkTyVars :: [LHsType RdrName] -> Bool -> P (Maybe [LHsType RdrName]) +checkTyVars tparms nonVarsOk = + do + areVars <- mapM chk tparms + return $ if and areVars then Nothing else Just tparms where -- Check that the name space is correct! chk (L l (HsKindSig (L _ (HsTyVar tv)) k)) - | isRdrTyVar tv = return () + | isRdrTyVar tv = return True chk (L l (HsTyVar tv)) - | isRdrTyVar tv = return () + | isRdrTyVar tv = return True chk (L l other) - = parseError l "Type found where type variable expected" - -checkSynHdr :: LHsType RdrName -> P (Located RdrName, [LHsTyVarBndr RdrName]) -checkSynHdr ty = do { (_, tc, tvs, Just tparms) <- checkTyClHdr (noLoc []) ty - ; checkTyVars tparms - ; return (tc, tvs) } + | nonVarsOk = return False + | otherwise = + parseError l "Type found where type variable expected" +-- Check whether the type arguments in a type synonym head are simply +-- variables. If not, we have a type equation of a type function and return +-- all patterns. +-- +checkSynHdr :: LHsType RdrName + -> Bool -- non-variables admitted? + -> P (Located RdrName, -- head symbol + [LHsTyVarBndr RdrName], -- parameters + Maybe [LHsType RdrName]) -- type patterns +checkSynHdr ty nonVarsOk = + do { (_, tc, tvs, Just tparms) <- checkTyClHdr (noLoc []) ty + ; typats <- checkTyVars tparms nonVarsOk + ; return (tc, tvs, typats) } + + +-- Well-formedness check and decomposition of type and class heads. +-- checkTyClHdr :: LHsContext RdrName -> LHsType RdrName -> P (LHsContext RdrName, -- the type context Located RdrName, -- the head symbol (type or class name) @@ -493,7 +513,7 @@ extractTyVars tvs = collects [] tvs checkTopTyClD :: LTyClDecl RdrName -> P (HsDecl RdrName) checkTopTyClD (L _ d@TyData {tcdTyPats = Just typats}) = do - checkTyVars typats + checkTyVars typats False return $ TyClD d {tcdTyPats = Nothing} checkTopTyClD (L _ d) = return $ TyClD d -- 1.7.10.4