X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcGenDeriv.lhs;h=499a839aadaeeceac715aa8155d0d157f2adeea5;hp=40e091d475fcdf9e93cb8d499646a1f9e2fd538f;hb=9ff76535edb25ab7434284adddb5c64708ecb547;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1 diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs index 40e091d..499a839 100644 --- a/compiler/typecheck/TcGenDeriv.lhs +++ b/compiler/typecheck/TcGenDeriv.lhs @@ -1,7 +1,9 @@ % +% (c) The University of Glasgow 2006 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -\section[TcGenDeriv]{Generating derived instance declarations} + +TcGenDeriv: Generating derived instance declarations This module is nominally ``subordinate'' to @TcDeriv@, which is the ``official'' interface to deriving-related things. @@ -29,37 +31,28 @@ module TcGenDeriv ( #include "HsVersions.h" import HsSyn -import RdrName ( RdrName, mkVarUnqual, getRdrName, mkRdrUnqual, - mkDerivedRdrName ) -import BasicTypes ( Fixity(..), maxPrecedence, Boxity(..) ) -import DataCon ( isNullarySrcDataCon, dataConTag, - dataConOrigArgTys, dataConSourceArity, fIRST_TAG, - DataCon, dataConName, dataConIsInfix, - dataConFieldLabels ) -import Name ( getOccString, getSrcLoc, Name, NamedThing(..) ) - -import HscTypes ( FixityEnv, lookupFixity ) +import RdrName +import BasicTypes +import DataCon +import Name + +import HscTypes import PrelInfo import PrelNames -import MkId ( eRROR_ID ) -import PrimOp ( PrimOp(..) ) -import SrcLoc ( Located(..), noLoc, srcLocSpan ) -import TyCon ( TyCon, isNewTyCon, tyConDataCons, isEnumerationTyCon, tyConArity, - maybeTyConSingleCon, tyConFamilySize, tyConTyVars, tyConName - ) -import TcType ( isUnLiftedType, tcEqType, Type ) -import TysPrim ( charPrimTy, intPrimTy, wordPrimTy, addrPrimTy, floatPrimTy, doublePrimTy, - intPrimTyCon ) -import TysWiredIn ( charDataCon, intDataCon, floatDataCon, doubleDataCon, - intDataCon_RDR, true_RDR, false_RDR ) -import Util ( zipWithEqual, isSingleton, - zipWith3Equal, nOfThem, zipEqual ) -import Constants -import List ( partition, intersperse ) +import MkId +import PrimOp +import SrcLoc +import TyCon +import TcType +import TysPrim +import TysWiredIn +import Util import Outputable import FastString import OccName import Bag + +import Data.List ( partition, intersperse ) \end{code} %************************************************************************ @@ -354,6 +347,8 @@ gen_Ord_binds tycon = let eq_expr = nested_compare_expr tys as bs in careful_compare_Case tycon ty eq_expr (nlHsVar a) (nlHsVar b) + nested_compare_expr _ _ _ = panic "nested_compare_expr" -- Args always equal length + default_rhs | null nullary_cons = impossible_Expr -- Keep desugarer from complaining about -- inexhaustive patterns | otherwise = eqTag_Expr -- Some nullary constructors; @@ -692,7 +687,7 @@ Example infix 4 %% data T = Int %% Int | T1 { f1 :: Int } - | T2 Int + | T2 T instance Read T where @@ -704,7 +699,9 @@ instance Read T where y <- ReadP.step Read.readPrec return (x %% y)) +++ - prec appPrec ( + prec (appPrec+1) ( + -- Note the "+1" part; "T2 T1 {f1=3}" should parse ok + -- Record construction binds even more tightly than application do Ident "T1" <- Lex.lex Punc '{' <- Lex.lex Ident "f1" <- Lex.lex @@ -753,24 +750,29 @@ gen_Read_binds get_fixity tycon [con] -> [nlHsDo DoExpr [bindLex (ident_pat (data_con_str con))] (result_expr con [])] _ -> [nlHsApp (nlHsVar choose_RDR) - (nlList (map mk_pair nullary_cons))] + (nlList (map mk_pair nullary_cons))] - mk_pair con = nlTuple [nlHsLit (mkHsString (data_con_str con)), - nlHsApp (nlHsVar returnM_RDR) (nlHsVar (getRdrName con))] - Boxed + mk_pair con = nlTuple [nlHsLit (mkHsString (data_con_str con)), + result_expr con []] + Boxed read_non_nullary_con data_con - = nlHsApps prec_RDR [nlHsIntLit prec, nlHsDo DoExpr stmts body] + | is_infix = mk_parser infix_prec infix_stmts body + | is_record = mk_parser record_prec record_stmts body +-- Using these two lines instead allows the derived +-- read for infix and record bindings to read the prefix form +-- | is_infix = mk_alt prefix_parser (mk_parser infix_prec infix_stmts body) +-- | is_record = mk_alt prefix_parser (mk_parser record_prec record_stmts body) + | otherwise = prefix_parser where - stmts | is_infix = infix_stmts - | length labels > 0 = lbl_stmts - | otherwise = prefix_stmts - body = result_expr data_con as_needed con_str = data_con_str data_con + prefix_parser = mk_parser prefix_prec prefix_stmts body prefix_stmts -- T a b c - = [bindLex (ident_pat (wrapOpParens con_str))] + = (if not (isSym con_str) then + [bindLex (ident_pat con_str)] + else [read_punc "(", bindLex (symbol_pat con_str), read_punc ")"]) ++ read_args infix_stmts -- a %% b, or a `T` b @@ -780,7 +782,7 @@ gen_Read_binds get_fixity tycon else [read_punc "`", bindLex (ident_pat con_str), read_punc "`"]) ++ [read_a2] - lbl_stmts -- T { f1 = a, f2 = b } + record_stmts -- T { f1 = a, f2 = b } = [bindLex (ident_pat (wrapOpParens con_str)), read_punc "{"] ++ concat (intersperse [read_punc ","] field_stmts) @@ -792,18 +794,24 @@ gen_Read_binds get_fixity tycon labels = dataConFieldLabels data_con dc_nm = getName data_con is_infix = dataConIsInfix data_con + is_record = length labels > 0 as_needed = take con_arity as_RDRs read_args = zipWithEqual "gen_Read_binds" read_arg as_needed (dataConOrigArgTys data_con) (read_a1:read_a2:_) = read_args - prec = getPrec is_infix get_fixity dc_nm + + prefix_prec = appPrecedence + infix_prec = getPrecedence get_fixity dc_nm + record_prec = appPrecedence + 1 -- Record construction binds even more tightly + -- than application; e.g. T2 T1 {x=2} means T2 (T1 {x=2}) ------------------------------------------------------------------------ -- Helpers ------------------------------------------------------------------------ - mk_alt e1 e2 = genOpApp e1 alt_RDR e2 - bindLex pat = noLoc (mkBindStmt pat (nlHsVar lexP_RDR)) - con_app c as = nlHsVarApps (getRdrName c) as - result_expr c as = nlHsApp (nlHsVar returnM_RDR) (con_app c as) + mk_alt e1 e2 = genOpApp e1 alt_RDR e2 -- e1 +++ e2 + mk_parser p ss b = nlHsApps prec_RDR [nlHsIntLit p, nlHsDo DoExpr ss b] -- prec p (do { ss ; b }) + bindLex pat = noLoc (mkBindStmt pat (nlHsVar lexP_RDR)) -- pat <- lexP + con_app con as = nlHsVarApps (getRdrName con) as -- con as + result_expr con as = nlHsApp (nlHsVar returnM_RDR) (con_app con as) -- return (con as) punc_pat s = nlConPat punc_RDR [nlLitPat (mkHsString s)] -- Punc 'c' ident_pat s = nlConPat ident_RDR [nlLitPat (mkHsString s)] -- Ident "foo" @@ -1199,12 +1207,13 @@ gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag) (nlHsApp (nlHsVar getTag_RDR) a_Expr))) (noLoc (mkExplicitHsForAllTy (map (noLoc.UserTyVar) tvs) (noLoc []) con2tag_ty)) - con2tag_ty = foldl nlHsAppTy (nlHsTyVar (getRdrName tycon)) - (map nlHsTyVar tvs) + con2tag_ty = nlHsTyConApp (getRdrName tycon) (map nlHsTyVar tvs) `nlHsFunTy` nlHsTyVar (getRdrName intPrimTyCon) - lots_of_constructors = tyConFamilySize tycon > mAX_FAMILY_SIZE_FOR_VEC_RETURNS + lots_of_constructors = tyConFamilySize tycon > 8 + -- was: mAX_FAMILY_SIZE_FOR_VEC_RETURNS + -- but we don't do vectored returns any more. mk_stuff :: DataCon -> ([LPat RdrName], LHsExpr RdrName) mk_stuff con = ([nlWildConPat con], @@ -1316,7 +1325,6 @@ box_con_tbl = [(charPrimTy, getRdrName charDataCon) ,(intPrimTy, getRdrName intDataCon) ,(wordPrimTy, wordDataCon_RDR) - ,(addrPrimTy, addrDataCon_RDR) ,(floatPrimTy, getRdrName floatDataCon) ,(doublePrimTy, getRdrName doubleDataCon) ] @@ -1371,6 +1379,7 @@ showParen_Expr e1 e2 = nlHsApp (nlHsApp (nlHsVar showParen_RDR) e1) e2 nested_compose_Expr :: [LHsExpr RdrName] -> LHsExpr RdrName +nested_compose_Expr [] = panic "nested_compose_expr" -- Arg is always non-empty nested_compose_Expr [e] = parenify e nested_compose_Expr (e:es) = nlHsApp (nlHsApp (nlHsVar compose_RDR) (parenify e)) (nested_compose_Expr es)