#include "HsVersions.h"
#ifdef GHCI /* Only if bootstrapped */
-import {-# SOURCE #-} TcSplice( tcSpliceExpr )
-import TcEnv ( bracketOK, tcMetaTy )
+import {-# SOURCE #-} TcSplice( tcSpliceExpr, tcBracket )
+import TcEnv ( bracketOK )
import TcSimplify ( tcSimplifyBracket )
-import PrelNames ( exprTyConName )
-import HsSyn ( HsBracket(..) )
+import DsMeta ( liftName )
#endif
import HsSyn ( HsExpr(..), HsLit(..), ArithSeqInfo(..),
)
import FieldLabel ( FieldLabel, fieldLabelName, fieldLabelType, fieldLabelTyCon )
import Id ( Id, idType, recordSelectorFieldLabel, isRecordSelector, isDataConWrapId_maybe )
-import DataCon ( dataConFieldLabels, dataConSig,
- dataConStrictMarks
- )
+import DataCon ( DataCon, dataConFieldLabels, dataConSig, dataConStrictMarks )
import Name ( Name, isExternalName )
import TyCon ( TyCon, tyConTyVars, tyConTheta, isAlgTyCon, tyConDataCons )
import Subst ( mkTopTyVarSubst, substTheta, substTy )
enumFromName, enumFromThenName,
enumFromToName, enumFromThenToName,
enumFromToPName, enumFromThenToPName,
- ioTyConName, liftName
+ ioTyConName
)
import ListSetOps ( minusList )
import CmdLineOpts
-- Typecheck the record bindings
tcRecordBinds tycon ty_args rbinds `thenM` \ rbinds' ->
- let
- (missing_s_fields, missing_fields) = missingFields rbinds data_con
- in
- checkM (null missing_s_fields)
- (mappM_ (addErrTc . missingStrictFieldCon con_name) missing_s_fields)
- `thenM_`
- doptM Opt_WarnMissingFields `thenM` \ warn ->
- checkM (not (warn && notNull missing_fields))
- (mappM_ ((warnTc True) . missingFieldCon con_name) missing_fields)
- `thenM_`
+ -- Check for missing fields
+ checkMissingFields data_con rbinds `thenM_`
returnM (RecordConOut data_con con_expr rbinds')
tcMonoExpr (HsSplice n expr) res_ty = tcSpliceExpr n expr res_ty
-tcMonoExpr (HsBracket (ExpBr expr)) res_ty
+tcMonoExpr (HsBracket brack) res_ty
= getStage `thenM` \ level ->
case bracketOK level of {
Nothing -> failWithTc (illegalBracket level) ;
-- it again when we actually use it.
newMutVar [] `thenM` \ pending_splices ->
getLIEVar `thenM` \ lie_var ->
- newTyVarTy openTypeKind `thenM` \ any_ty ->
setStage (Brack next_level pending_splices lie_var) (
- getLIE (tcMonoExpr expr any_ty)
- ) `thenM` \ (expr', lie) ->
- tcSimplifyBracket lie `thenM_`
+ getLIE (tcBracket brack)
+ ) `thenM` \ (meta_ty, lie) ->
+ tcSimplifyBracket lie `thenM_`
- tcMetaTy exprTyConName `thenM` \ meta_exp_ty ->
- unifyTauTy res_ty meta_exp_ty `thenM_`
+ unifyTauTy res_ty meta_ty `thenM_`
-- Return the original expression, not the type-decorated one
readMutVar pending_splices `thenM` \ pendings ->
- returnM (HsBracketOut (ExpBr expr) pendings)
+ returnM (HsBracketOut brack pendings)
}
#endif GHCI
\end{code}
= tcLookupIdLvl name `thenM` \ (id, bind_lvl) ->
-- Check for cross-stage lifting
+#ifdef GHCI
getStage `thenM` \ use_stage ->
case use_stage of
Brack use_lvl ps_var lie_var
in
checkTc (wellStaged bind_lvl use_lvl)
(badStageErr id bind_lvl use_lvl) `thenM_`
-
+#endif
+ -- This is the bit that handles the no-Template-Haskell case
case isDataConWrapId_maybe id of
Nothing -> loop (HsVar id) (idType id)
Just data_con -> inst_data_con id data_con
where
field_names = map fieldLabelName (dataConFieldLabels data_con)
-missingFields rbinds data_con
- | null field_labels = ([], []) -- Not declared as a record;
- -- But C{} is still valid
- | otherwise
- = (missing_strict_fields, other_missing_fields)
+checkMissingFields :: DataCon -> RenamedRecordBinds -> TcM ()
+checkMissingFields data_con rbinds
+ | null field_labels -- Not declared as a record;
+ -- But C{} is still valid if no strict fields
+ = if any isMarkedStrict field_strs then
+ -- Illegal if any arg is strict
+ addErrTc (missingStrictFields data_con [])
+ else
+ returnM ()
+
+ | otherwise -- A record
+ = checkM (null missing_s_fields)
+ (addErrTc (missingStrictFields data_con missing_s_fields)) `thenM_`
+
+ doptM Opt_WarnMissingFields `thenM` \ warn ->
+ checkM (not (warn && notNull missing_ns_fields))
+ (warnTc True (missingFields data_con missing_ns_fields))
+
where
- missing_strict_fields
+ missing_s_fields
= [ fl | (fl, str) <- field_info,
isMarkedStrict str,
not (fieldLabelName fl `elem` field_names_used)
]
- other_missing_fields
+ missing_ns_fields
= [ fl | (fl, str) <- field_info,
not (isMarkedStrict str),
not (fieldLabelName fl `elem` field_names_used)
field_info = zipEqual "missingFields"
field_labels
- (dropList ex_theta (dataConStrictMarks data_con))
+ field_strs
+
+ field_strs = dropList ex_theta (dataConStrictMarks data_con)
-- The 'drop' is because dataConStrictMarks
-- includes the existential dictionaries
(_, _, _, ex_theta, _, _) = dataConSig data_con
notSelector field
= hsep [quotes (ppr field), ptext SLIT("is not a record selector")]
-missingStrictFieldCon :: Name -> FieldLabel -> SDoc
-missingStrictFieldCon con field
- = hsep [ptext SLIT("Constructor") <+> quotes (ppr con),
- ptext SLIT("does not have the required strict field"), quotes (ppr field)]
-
-missingFieldCon :: Name -> FieldLabel -> SDoc
-missingFieldCon con field
- = hsep [ptext SLIT("Field") <+> quotes (ppr field),
- ptext SLIT("is not initialised")]
+missingStrictFields :: DataCon -> [FieldLabel] -> SDoc
+missingStrictFields con fields
+ = header <> rest
+ where
+ rest | null fields = empty -- Happens for non-record constructors
+ -- with strict fields
+ | otherwise = colon <+> pprWithCommas ppr fields
+
+ header = ptext SLIT("Constructor") <+> quotes (ppr con) <+>
+ ptext SLIT("does not have the required strict field(s)")
+
+
+missingFields :: DataCon -> [FieldLabel] -> SDoc
+missingFields con fields
+ = ptext SLIT("Fields of") <+> quotes (ppr con) <+> ptext SLIT("not initialised:")
+ <+> pprWithCommas ppr fields
polySpliceErr :: Id -> SDoc
polySpliceErr id
projects / ghc-hetmet.git / blobdiff