Commit 72264dbc authored by chak@cse.unsw.edu.au.'s avatar chak@cse.unsw.edu.au.

Parser support for assoc synonyms

Fri Jul 28 21:52:46 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
  * Parser support for assoc synonyms
parent 658372b8
......@@ -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,
......
......@@ -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
......
......@@ -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),
......
......@@ -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) }
-----------------------------------------------------------------------------
......
......@@ -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
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment