%
+% (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.
#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}
%************************************************************************
= 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;
infix 4 %%
data T = Int %% Int
| T1 { f1 :: Int }
- | T2 Int
+ | T2 T
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
[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
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)
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"
(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],
[(charPrimTy, getRdrName charDataCon)
,(intPrimTy, getRdrName intDataCon)
,(wordPrimTy, wordDataCon_RDR)
- ,(addrPrimTy, addrDataCon_RDR)
,(floatPrimTy, getRdrName floatDataCon)
,(doublePrimTy, getRdrName doubleDataCon)
]
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)
projects / ghc-hetmet.git / blobdiff