idPrimRep, getInstIdModule,
getMentionedTyConsAndClassesFromId,
- dataConTag,
- dataConSig, getInstantiatedDataConSig,
+ dataConTag, dataConStrictMarks,
+ dataConSig, dataConArgTys,
dataConTyCon, dataConArity,
dataConFieldLabels,
import Name ( appendRdr, nameUnique, mkLocalName, isLocalName,
isLocallyDefinedName, isPreludeDefinedName,
nameOrigName,
- RdrName(..), Name
- )
-import FieldLabel ( fieldLabelName, FieldLabel{-instances-} )
-import Outputable ( isAvarop, isAconop, getLocalName,
+ isAvarop, isAconop, getLocalName,
isLocallyDefined, isPreludeDefined,
getOrigName, getOccName,
- isExported, ExportFlag(..)
+ isExported, ExportFlag(..),
+ RdrName(..), Name
)
+import FieldLabel ( fieldLabelName, FieldLabel{-instances-} )
import PragmaInfo ( PragmaInfo(..) )
import PrelMods ( pRELUDE_BUILTIN )
import PprType ( getTypeString, typeMaybeString, specMaybeTysSuffix,
import Unique ( mkTupleDataConUnique, pprUnique, showUnique,
Unique{-instance Ord3-}
)
-import Util ( mapAccumL, nOfThem,
+import Util ( mapAccumL, nOfThem, zipEqual,
panic, panic#, pprPanic, assertPanic
)
\end{code}
= let
(inst_env, tyvars, tyvar_tys)
= instantiateTyVarTemplates tvs
- (map getItsUnique tvs)
+ (map uniqueOf tvs)
in
-- the "context" and "arg_tys" have TyVarTemplates in them, so
-- we instantiate those types to have the right TyVars in them
BEND
where
tyvar_tmpls = take arity alphaTyVars
- (_, tyvars, tyvar_tys) = instantiateTyVarTemplates tyvar_tmpls (map getItsUnique tyvar_tmpls)
+ (_, tyvars, tyvar_tys) = instantiateTyVarTemplates tyvar_tmpls (map uniqueOf tyvar_tmpls)
-}
fIRST_TAG :: ConTag
dataConFieldLabels :: DataCon -> [FieldLabel]
dataConFieldLabels (Id _ _ (DataConId _ _ _ fields _ _ _ _) _ _) = fields
+dataConFieldLabels (Id _ _ (TupleConId _ _) _ _) = []
+
+dataConStrictMarks :: DataCon -> [StrictnessMark]
+dataConStrictMarks (Id _ _ (DataConId _ _ stricts _ _ _ _ _) _ _) = stricts
+dataConStrictMarks (Id _ _ (TupleConId _ arity) _ _)
+ = take arity (repeat NotMarkedStrict)
+
+dataConArgTys :: DataCon
+ -> [Type] -- Instantiated at these types
+ -> [Type] -- Needs arguments of these types
+dataConArgTys con_id inst_tys
+ = map (instantiateTy tenv) arg_tys
+ where
+ (tyvars, _, arg_tys, _) = dataConSig con_id
+ tenv = tyvars `zipEqual` inst_tys
\end{code}
\begin{code}
recordSelectorFieldLabel (Id _ _ (RecordSelId lbl) _ _) = lbl
\end{code}
-{- LATER
-dataConTyCon (Id _ _ _ (SpecId unspec tys _))
- = mkSpecTyCon (dataConTyCon unspec) tys
-
-dataConSig (Id _ _ _ (SpecId unspec ty_maybes _))
- = (spec_tyvars, spec_theta_ty, spec_arg_tys, spec_tycon)
- where
- (tyvars, theta_ty, arg_tys, tycon) = dataConSig unspec
-
- ty_env = tyvars `zip` ty_maybes
-
- spec_tyvars = foldr nothing_tyvars [] ty_env
- nothing_tyvars (tyvar, Nothing) l = tyvar : l
- nothing_tyvars (tyvar, Just ty) l = l
-
- spec_env = foldr just_env [] ty_env
- just_env (tyvar, Nothing) l = l
- just_env (tyvar, Just ty) l = (tyvar, ty) : l
- spec_arg_tys = map (instantiateTauTy spec_env) arg_tys
-
- spec_theta_ty = if null theta_ty then []
- else panic "dataConSig:ThetaTy:SpecDataCon"
- spec_tycon = mkSpecTyCon tycon ty_maybes
--}
-\end{code}
-
-\begin{pseudocode}
-@getInstantiatedDataConSig@ takes a constructor and some types to which
-it is applied; it returns its signature instantiated to these types.
-
-\begin{code}
-getInstantiatedDataConSig ::
- DataCon -- The data constructor
- -- Not a specialised data constructor
- -> [TauType] -- Types to which applied
- -- Must be fully applied i.e. contain all types of tycon
- -> ([TauType], -- Types of dict args
- [TauType], -- Types of regular args
- TauType -- Type of result
- )
-
-getInstantiatedDataConSig data_con inst_tys
- = ASSERT(isDataCon data_con)
- let
- (tvs, theta, arg_tys, tycon) = dataConSig data_con
-
- inst_env = ASSERT(length tvs == length inst_tys)
- tvs `zip` inst_tys
-
- theta_tys = [ instantiateTy inst_env (mkDictTy c t) | (c,t) <- theta ]
- cmpnt_tys = [ instantiateTy inst_env arg_ty | arg_ty <- arg_tys ]
- result_ty = instantiateTy inst_env (applyTyCon tycon inst_tys)
- in
- -- Are the first/third results ever used?
- (theta_tys, cmpnt_tys, result_ty)
-\end{code}
Data type declarations are of the form:
\begin{verbatim}
mkImplicitName, isImplicitName,
mkBuiltinName,
+ NamedThing(..), -- class
+ ExportFlag(..), isExported,
+
nameUnique,
nameOrigName,
nameOccName,
nameExportFlag,
nameSrcLoc,
isLocallyDefinedName,
- isPreludeDefinedName
+ isPreludeDefinedName,
+
+ getOrigName, getOccName, getExportFlag,
+ getSrcLoc, isLocallyDefined, isPreludeDefined,
+ getLocalName, getOrigNameRdr, ltLexical,
+
+ isOpLexeme, pprOp, pprNonOp,
+ isConop, isAconop, isAvarid, isAvarop
) where
import Ubiq
import CStrings ( identToC, cSEP )
-import Outputable ( Outputable(..), ExportFlag(..), isConop )
+import Outputable ( Outputable(..) )
import PprStyle ( PprStyle(..), codeStyle )
import Pretty
import PrelMods ( pRELUDE )
pp_prov _ = ppNil
\end{code}
+%************************************************************************
+%* *
+\subsection[ExportFlag-datatype]{The @ExportFlag@ datatype}
+%* *
+%************************************************************************
+
+The export flag @ExportAll@ means `export all there is', so there are
+times when it is attached to a class or data type which has no
+ops/constructors (if the class/type was imported abstractly). In
+fact, @ExportAll@ is attached to everything except to classes/types
+which are being {\em exported} abstractly, regardless of how they were
+imported.
+
+\begin{code}
+data ExportFlag
+ = ExportAll -- export with all constructors/methods
+ | ExportAbs -- export abstractly
+ | NotExported
+
+isExported a
+ = case (getExportFlag a) of
+ NotExported -> False
+ _ -> True
+
+#ifdef USE_ATTACK_PRAGMAS
+{-# SPECIALIZE isExported :: Class -> Bool #-}
+{-# SPECIALIZE isExported :: Id -> Bool #-}
+{-# SPECIALIZE isExported :: TyCon -> Bool #-}
+#endif
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Overloaded functions related to Names}
+%* *
+%************************************************************************
+
+\begin{code}
+class NamedThing a where
+ getName :: a -> Name
+\end{code}
+
+\begin{code}
+getOrigName :: NamedThing a => a -> (Module, FAST_STRING)
+getOccName :: NamedThing a => a -> RdrName
+getExportFlag :: NamedThing a => a -> ExportFlag
+getSrcLoc :: NamedThing a => a -> SrcLoc
+isLocallyDefined :: NamedThing a => a -> Bool
+isPreludeDefined :: NamedThing a => a -> Bool
+
+getOrigName = nameOrigName . getName
+getOccName = nameOccName . getName
+getExportFlag = nameExportFlag . getName
+getSrcLoc = nameSrcLoc . getName
+isLocallyDefined = isLocallyDefinedName . getName
+isPreludeDefined = isPreludeDefinedName . getName
+
+getLocalName :: (NamedThing a) => a -> FAST_STRING
+getLocalName = snd . getOrigName
+
+getOrigNameRdr :: (NamedThing a) => a -> RdrName
+getOrigNameRdr n | isPreludeDefined n = Unqual str
+ | otherwise = Qual mod str
+ where
+ (mod,str) = getOrigName n
+\end{code}
+
+@ltLexical@ is used for sorting things into lexicographical order, so
+as to canonicalize interfaces. [Regular @(<)@ should be used for fast
+comparison.]
+
+\begin{code}
+a `ltLexical` b
+ = BIND isLocallyDefined a _TO_ a_local ->
+ BIND isLocallyDefined b _TO_ b_local ->
+ BIND getOrigName a _TO_ (a_mod, a_name) ->
+ BIND getOrigName b _TO_ (b_mod, b_name) ->
+ if a_local || b_local then
+ a_name < b_name -- can't compare module names
+ else
+ case _CMP_STRING_ a_mod b_mod of
+ LT_ -> True
+ EQ_ -> a_name < b_name
+ GT__ -> False
+ BEND BEND BEND BEND
+
+#ifdef USE_ATTACK_PRAGMAS
+{-# SPECIALIZE ltLexical :: Class -> Class -> Bool #-}
+{-# SPECIALIZE ltLexical :: Id -> Id -> Bool #-}
+{-# SPECIALIZE ltLexical :: TyCon -> TyCon -> Bool #-}
+#endif
+\end{code}
+
+These functions test strings to see if they fit the lexical categories
+defined in the Haskell report. Normally applied as in e.g. @isConop
+(getLocalName foo)@
+
+\begin{code}
+isConop, isAconop, isAvarid, isAvarop :: FAST_STRING -> Bool
+
+isConop cs
+ | _NULL_ cs = False
+ | c == '_' = isConop (_TAIL_ cs) -- allow for leading _'s
+ | otherwise = isUpper c || c == ':'
+ || c == '[' || c == '(' -- [] () and (,,) come is as Conop strings !!!
+ || isUpperISO c
+ where
+ c = _HEAD_ cs
+
+isAconop cs
+ | _NULL_ cs = False
+ | otherwise = c == ':'
+ where
+ c = _HEAD_ cs
+
+isAvarid cs
+ | _NULL_ cs = False
+ | c == '_' = isAvarid (_TAIL_ cs) -- allow for leading _'s
+ | isLower c = True
+ | isLowerISO c = True
+ | otherwise = False
+ where
+ c = _HEAD_ cs
+
+isAvarop cs
+ | _NULL_ cs = False
+ | isLower c = False
+ | isUpper c = False
+ | c `elem` "!#$%&*+./<=>?@\\^|~-" = True
+ | isSymbolISO c = True
+ | otherwise = False
+ where
+ c = _HEAD_ cs
+
+isSymbolISO c = ord c `elem` (0xd7 : 0xf7 : [0xa1 .. 0xbf])
+isUpperISO c = 0xc0 <= oc && oc <= 0xde && oc /= 0xd7 where oc = ord c
+isLowerISO c = 0xdf <= oc && oc <= 0xff && oc /= 0xf7 where oc = ord c
+\end{code}
+
+And one ``higher-level'' interface to those:
+
+\begin{code}
+isOpLexeme :: NamedThing a => a -> Bool
+
+isOpLexeme v
+ = let str = snd (getOrigName v) in isAvarop str || isAconop str
+
+-- print `vars`, (op) correctly
+pprOp, pprNonOp :: (NamedThing name, Outputable name) => PprStyle -> name -> Pretty
+
+pprOp sty var
+ = if isOpLexeme var
+ then ppr sty var
+ else ppBesides [ppChar '`', ppr sty var, ppChar '`']
+
+pprNonOp sty var
+ = if isOpLexeme var
+ then ppBesides [ppLparen, ppr sty var, ppRparen]
+ else ppr sty var
+
+#ifdef USE_ATTACK_PRAGMAS
+{-# SPECIALIZE isOpLexeme :: Id -> Bool #-}
+{-# SPECIALIZE pprNonOp :: PprStyle -> Id -> Pretty #-}
+{-# SPECIALIZE pprNonOp :: PprStyle -> TyCon -> Pretty #-}
+{-# SPECIALIZE pprOp :: PprStyle -> Id -> Pretty #-}
+#endif
+\end{code}
--<mkdependHS:friends> UniqSupply
module Unique (
- Unique, Uniquable(..),
+ Unique,
u2i, -- hack: used in UniqFM
pprUnique, pprUnique10, showUnique,
charPrimTyConKey,
charTyConKey,
consDataConKey,
+ dataClassKey,
doubleDataConKey,
doublePrimTyConKey,
doubleTyConKey,
parErrorIdKey,
parIdKey,
patErrorIdKey,
+ recConErrorIdKey,
+ recUpdErrorIdKey,
+ irrefutPatErrorIdKey,
+ nonExhaustiveGuardsErrorIdKey,
primIoTyConKey,
ratioDataConKey,
ratioTyConKey,
cmp = cmpUnique
-----------------
-class Uniquable a where
- uniqueOf :: a -> Unique
-
instance Uniquable Unique where
uniqueOf u = u
\end{code}
binaryClassKey = mkPreludeClassUnique 16
cCallableClassKey = mkPreludeClassUnique 17
cReturnableClassKey = mkPreludeClassUnique 18
+dataClassKey = mkPreludeClassUnique 19
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-absentErrorIdKey = mkPreludeMiscIdUnique 1
-appendIdKey = mkPreludeMiscIdUnique 2
-augmentIdKey = mkPreludeMiscIdUnique 3
-buildIdKey = mkPreludeMiscIdUnique 4
-errorIdKey = mkPreludeMiscIdUnique 5
-foldlIdKey = mkPreludeMiscIdUnique 6
-foldrIdKey = mkPreludeMiscIdUnique 7
-forkIdKey = mkPreludeMiscIdUnique 8
-int2IntegerIdKey = mkPreludeMiscIdUnique 9
-integerMinusOneIdKey = mkPreludeMiscIdUnique 10
-integerPlusOneIdKey = mkPreludeMiscIdUnique 11
-integerPlusTwoIdKey = mkPreludeMiscIdUnique 12
-integerZeroIdKey = mkPreludeMiscIdUnique 13
-packCStringIdKey = mkPreludeMiscIdUnique 14
-parErrorIdKey = mkPreludeMiscIdUnique 15
-parIdKey = mkPreludeMiscIdUnique 16
-patErrorIdKey = mkPreludeMiscIdUnique 17
-realWorldPrimIdKey = mkPreludeMiscIdUnique 18
-runSTIdKey = mkPreludeMiscIdUnique 19
-seqIdKey = mkPreludeMiscIdUnique 20
-traceIdKey = mkPreludeMiscIdUnique 21
-unpackCString2IdKey = mkPreludeMiscIdUnique 22
-unpackCStringAppendIdKey= mkPreludeMiscIdUnique 23
-unpackCStringFoldrIdKey = mkPreludeMiscIdUnique 24
-unpackCStringIdKey = mkPreludeMiscIdUnique 25
-voidPrimIdKey = mkPreludeMiscIdUnique 26
-mainIdKey = mkPreludeMiscIdUnique 27
-mainPrimIOIdKey = mkPreludeMiscIdUnique 28
+absentErrorIdKey = mkPreludeMiscIdUnique 1
+appendIdKey = mkPreludeMiscIdUnique 2
+augmentIdKey = mkPreludeMiscIdUnique 3
+buildIdKey = mkPreludeMiscIdUnique 4
+errorIdKey = mkPreludeMiscIdUnique 5
+foldlIdKey = mkPreludeMiscIdUnique 6
+foldrIdKey = mkPreludeMiscIdUnique 7
+forkIdKey = mkPreludeMiscIdUnique 8
+int2IntegerIdKey = mkPreludeMiscIdUnique 9
+integerMinusOneIdKey = mkPreludeMiscIdUnique 10
+integerPlusOneIdKey = mkPreludeMiscIdUnique 11
+integerPlusTwoIdKey = mkPreludeMiscIdUnique 12
+integerZeroIdKey = mkPreludeMiscIdUnique 13
+packCStringIdKey = mkPreludeMiscIdUnique 14
+parErrorIdKey = mkPreludeMiscIdUnique 15
+parIdKey = mkPreludeMiscIdUnique 16
+patErrorIdKey = mkPreludeMiscIdUnique 17
+realWorldPrimIdKey = mkPreludeMiscIdUnique 18
+runSTIdKey = mkPreludeMiscIdUnique 19
+seqIdKey = mkPreludeMiscIdUnique 20
+traceIdKey = mkPreludeMiscIdUnique 21
+unpackCString2IdKey = mkPreludeMiscIdUnique 22
+unpackCStringAppendIdKey = mkPreludeMiscIdUnique 23
+unpackCStringFoldrIdKey = mkPreludeMiscIdUnique 24
+unpackCStringIdKey = mkPreludeMiscIdUnique 25
+voidPrimIdKey = mkPreludeMiscIdUnique 26
+mainIdKey = mkPreludeMiscIdUnique 27
+mainPrimIOIdKey = mkPreludeMiscIdUnique 28
+recConErrorIdKey = mkPreludeMiscIdUnique 29
+recUpdErrorIdKey = mkPreludeMiscIdUnique 30
+irrefutPatErrorIdKey = mkPreludeMiscIdUnique 31
+nonExhaustiveGuardsErrorIdKey = mkPreludeMiscIdUnique 32
#ifdef GRAN
-parLocalIdKey = mkPreludeMiscIdUnique 29
-parGlobalIdKey = mkPreludeMiscIdUnique 30
-noFollowIdKey = mkPreludeMiscIdUnique 31
-copyableIdKey = mkPreludeMiscIdUnique 32
+parLocalIdKey = mkPreludeMiscIdUnique 33
+parGlobalIdKey = mkPreludeMiscIdUnique 34
+noFollowIdKey = mkPreludeMiscIdUnique 35
+copyableIdKey = mkPreludeMiscIdUnique 36
#endif
\end{code}
their own uniques so we can look them up easily when we want
to conjure them up during type checking.
\begin{code}
-fromIntClassOpKey = mkPreludeMiscIdUnique 33
-fromIntegerClassOpKey = mkPreludeMiscIdUnique 34
-fromRationalClassOpKey = mkPreludeMiscIdUnique 35
-enumFromClassOpKey = mkPreludeMiscIdUnique 36
-enumFromThenClassOpKey = mkPreludeMiscIdUnique 37
-enumFromToClassOpKey = mkPreludeMiscIdUnique 38
-enumFromThenToClassOpKey= mkPreludeMiscIdUnique 39
-eqClassOpKey = mkPreludeMiscIdUnique 40
-geClassOpKey = mkPreludeMiscIdUnique 41
+fromIntClassOpKey = mkPreludeMiscIdUnique 37
+fromIntegerClassOpKey = mkPreludeMiscIdUnique 38
+fromRationalClassOpKey = mkPreludeMiscIdUnique 39
+enumFromClassOpKey = mkPreludeMiscIdUnique 40
+enumFromThenClassOpKey = mkPreludeMiscIdUnique 41
+enumFromToClassOpKey = mkPreludeMiscIdUnique 42
+enumFromThenToClassOpKey= mkPreludeMiscIdUnique 43
+eqClassOpKey = mkPreludeMiscIdUnique 44
+geClassOpKey = mkPreludeMiscIdUnique 45
\end{code}
GenId{-instance NamedThing-}
)
import Maybes ( catMaybes )
-import Outputable ( isLocallyDefined )
+import Name ( isLocallyDefined )
import PprAbsC ( pprAmode )
import PprStyle ( PprStyle(..) )
import StgSyn ( StgArg(..), StgLiveVars(..), GenStgArg(..) )
emptyIdSet,
GenId{-instance NamedThing-}
)
-import Outputable ( getLocalName )
+import Name ( getLocalName )
import PrimRep ( getPrimRepSize, PrimRep(..) )
import TyCon ( tyConDataCons, mkSpecTyCon )
import Type ( typePrimRep )
)
import IdInfo ( arityMaybe )
import Maybes ( assocMaybe, maybeToBool )
-import Outputable ( isLocallyDefined, getLocalName )
+import Name ( isLocallyDefined, getLocalName )
import PprStyle ( PprStyle(..) )
import PprType ( GenType{-instance Outputable-} )
import PrimRep ( getPrimRepSize, separateByPtrFollowness )
nullIdEnv, growIdEnvList, lookupIdEnv, IdEnv(..),
GenId{-instances-}
)
-import Outputable ( isLocallyDefined, getSrcLoc )
+import Name ( isLocallyDefined, getSrcLoc )
import PrelInfo ( liftDataCon, mkLiftTy, statePrimTyCon )
import TyCon ( isBoxedTyCon, TyCon{-instance-} )
import Type ( maybeAppDataTyCon, eqTy )
import Kind ( Kind{-instance-} )
import Literal ( literalType, Literal{-instance-} )
import Id ( idType, isBottomingId,
- getInstantiatedDataConSig, GenId{-instances-}
+ dataConArgTys, GenId{-instances-}
)
import Maybes ( catMaybes )
-import Outputable ( isLocallyDefined, getSrcLoc,
- Outputable(..){-instance * []-}
- )
+import Name ( isLocallyDefined, getSrcLoc )
+import Outputable ( Outputable(..){-instance * []-} )
import PprCore
import PprStyle ( PprStyle(..) )
import PprType ( GenType, GenTyVar, TyCon )
addErrL (mkAlgAltMsg1 scrut_ty)
Just (tycon, tys_applied, cons) ->
let
- (_, arg_tys, _) = getInstantiatedDataConSig con tys_applied
+ arg_tys = dataConArgTys con tys_applied
in
checkL (con `elem` cons) (mkAlgAltMsg2 scrut_ty con) `seqL`
checkL (length arg_tys == length args) (mkAlgAltMsg3 con args)
substCoreExpr, substCoreBindings
, mkCoreIfThenElse
- , mkErrorApp, escErrorMsg
+ , escErrorMsg -- ToDo: kill
, argToExpr
, unTagBinders, unTagBindersAlts
, manifestlyWHNF, manifestlyBottom
import PprType ( GenType{-instances-} )
import Pretty ( ppAboves )
import PrelInfo ( trueDataCon, falseDataCon,
- augmentId, buildId,
- pAT_ERROR_ID
+ augmentId, buildId
)
import PrimOp ( primOpType, PrimOp(..) )
import SrcLoc ( mkUnknownSrcLoc )
\end{code}
\begin{code}
-mkErrorApp :: Type -> Id -> String -> CoreExpr
+{- OLD:
+mkErrorApp :: Id -> Type -> Id -> String -> CoreExpr
-mkErrorApp ty str_var error_msg
+mkErrorApp err_fun ty str_var error_msg
= Let (NonRec str_var (Lit (NoRepStr (_PK_ error_msg)))) (
- mkApp (Var pAT_ERROR_ID) [] [ty] [VarArg str_var])
+ mkApp (Var err_fun) [] [ty] [VarArg str_var])
+-}
+escErrorMsg = panic "CoreUtils.escErrorMsg: To Die"
+{- OLD:
escErrorMsg [] = []
escErrorMsg ('%':xs) = '%' : '%' : escErrorMsg xs
escErrorMsg (x:xs) = x : escErrorMsg xs
+-}
\end{code}
For making @Apps@ and @Lets@, we must take appropriate evasive
)
import IdInfo ( ppIdInfo, StrictnessInfo(..) )
import Literal ( Literal{-instances-} )
+import Name ( isOpLexeme )
import Outputable -- quite a few things
import PprEnv
import PprType ( GenType{-instances-}, GenTyVar{-instance-} )
import Match ( matchWrapper )
import CmdLineOpts ( opt_SccProfilingOn, opt_CompilingPrelude )
-import CoreUtils ( escErrorMsg )
import CostCentre ( mkAllDictsCC, preludeDictsCostCentre )
import Id ( idType, DictVar(..), GenId )
import ListSetOps ( minusList, intersectLists )
\begin{code}
dsMonoBinds is_rec tyvars dicts binder_subst (FunMonoBind fun matches locn)
- = putSrcLocDs locn (
+ = putSrcLocDs locn $
let
- new_fun = binder_subst fun
+ new_fun = binder_subst fun
+ error_string = "function " ++ showForErr fun
in
- matchWrapper (FunMatch fun) matches (error_msg new_fun) `thenDs` \ (args, body) ->
+ matchWrapper (FunMatch fun) matches error_string `thenDs` \ (args, body) ->
returnDs [(new_fun,
mkLam tyvars (dicts ++ args) body)]
- )
- where
- error_msg fun = "%F" -- "incomplete pattern(s) to match in function \""
- ++ (escErrorMsg (ppShow 80 (ppr PprForUser fun))) ++ "\""
dsMonoBinds is_rec tyvars dicts binder_subst (PatMonoBind (VarPat v) grhss_and_binds locn)
- = putSrcLocDs locn (
- dsGuarded grhss_and_binds locn `thenDs` \ body_expr ->
+ = putSrcLocDs locn $
+ dsGuarded grhss_and_binds `thenDs` \ body_expr ->
returnDs [(binder_subst v, mkLam tyvars dicts body_expr)]
- )
\end{code}
%==============================================
\begin{code}
dsMonoBinds is_rec tyvars [] binder_subst (PatMonoBind pat grhss_and_binds locn)
- = putSrcLocDs locn (
+ = putSrcLocDs locn $
- dsGuarded grhss_and_binds locn `thenDs` \ body_expr ->
+ dsGuarded grhss_and_binds `thenDs` \ body_expr ->
{- KILLED by Sansom. 95/05
-- make *sure* there are no primitive types in the pattern
mkSelectorBinds tyvars pat
[(binder, binder_subst binder) | binder <- pat_binders]
body_expr
- )
where
pat_binders = collectTypedPatBinders pat
-- NB For a simple tuple pattern, these binders
import DsUtils
import CoreUtils ( coreExprType )
-import Id ( getInstantiatedDataConSig, mkTupleCon )
+import Id ( dataConArgTys, mkTupleCon )
import Maybes ( maybeToBool )
import PprStyle ( PprStyle(..) )
import PprType ( GenType{-instances-} )
(Just (tycon, tycon_arg_tys, data_cons)) = maybe_data_type
(the_data_con : other_data_cons) = data_cons
- (_, data_con_arg_tys, _) = getInstantiatedDataConSig the_data_con tycon_arg_tys
+ data_con_arg_tys = dataConArgTys the_data_con tycon_arg_tys
(data_con_arg_ty1 : data_con_arg_ty2 : _) = data_con_arg_tys
can't_see_datacons_error thing ty
Just (tycon, tycon_arg_tys, data_cons) = maybe_data_type
(the_data_con : other_data_cons) = data_cons
- (_, data_con_arg_tys, _) = getInstantiatedDataConSig the_data_con tycon_arg_tys
+ data_con_arg_tys = dataConArgTys the_data_con tycon_arg_tys
(the_prim_result_ty : other_args_tys) = data_con_arg_tys
(state_and_prim_datacon, state_and_prim_ty) = getStatePairingConInfo the_prim_result_ty
import HsSyn ( HsExpr(..), HsLit(..), ArithSeqInfo(..),
Match, Qual, HsBinds, Stmt, PolyType )
-import TcHsSyn ( TypecheckedHsExpr(..), TypecheckedHsBinds(..) )
+import TcHsSyn ( TypecheckedHsExpr(..), TypecheckedHsBinds(..),
+ TypecheckedRecordBinds(..)
+ )
import CoreSyn
import DsMonad
import DsCCall ( dsCCall )
import DsListComp ( dsListComp )
-import DsUtils ( mkAppDs, mkConDs, mkPrimDs, dsExprToAtom )
+import DsUtils ( mkAppDs, mkConDs, mkPrimDs, dsExprToAtom,
+ mkErrorAppDs, showForErr
+ )
import Match ( matchWrapper )
import CoreUnfold ( UnfoldingDetails(..), UnfoldingGuidance(..),
import CoreUtils ( coreExprType, substCoreExpr, argToExpr,
mkCoreIfThenElse, unTagBinders )
import CostCentre ( mkUserCC )
+import FieldLabel ( FieldLabel{-instance Eq/Outputable-} )
import Id ( mkTupleCon, idType, nullIdEnv, addOneToIdEnv,
- getIdUnfolding )
+ getIdUnfolding, dataConArgTys, dataConFieldLabels,
+ recordSelectorFieldLabel
+ )
import Literal ( mkMachInt, Literal(..) )
import MagicUFs ( MagicUnfoldingFun )
import PprStyle ( PprStyle(..) )
import PprType ( GenType )
import PrelInfo ( mkTupleTy, unitTy, nilDataCon, consDataCon,
- charDataCon, charTy )
+ charDataCon, charTy, rEC_CON_ERROR_ID,
+ rEC_UPD_ERROR_ID
+ )
import Pretty ( ppShow, ppBesides, ppPStr, ppStr )
-import Type ( splitSigmaTy, typePrimRep )
+import Type ( splitSigmaTy, splitFunTy, typePrimRep,
+ getAppDataTyCon
+ )
import TyVar ( nullTyVarEnv, addOneToTyVarEnv )
import Usage ( UVar(..) )
-import Util ( pprError, panic )
+import Util ( zipEqual, pprError, panic, assertPanic )
maybeBoxedPrimType = panic "DsExpr.maybeBoxedPrimType"
splitTyArgs = panic "DsExpr.splitTyArgs"
-- end of literals magic. --
dsExpr expr@(HsLam a_Match)
- = let
- error_msg = "%L" --> "pattern-matching failed in lambda"
- in
- matchWrapper LambdaMatch [a_Match] error_msg `thenDs` \ (binders, matching_code) ->
+ = matchWrapper LambdaMatch [a_Match] "lambda" `thenDs` \ (binders, matching_code) ->
returnDs ( mkValLam binders matching_code )
dsExpr expr@(HsApp e1 e2) = dsApp expr []
dsExpr expr@(HsCase discrim matches src_loc)
= putSrcLocDs src_loc $
- dsExpr discrim `thenDs` \ core_discrim ->
- let
- error_msg = "%C" --> "pattern-matching failed in case"
- in
- matchWrapper CaseMatch matches error_msg `thenDs` \ ([discrim_var], matching_code) ->
+ dsExpr discrim `thenDs` \ core_discrim ->
+ matchWrapper CaseMatch matches "case" `thenDs` \ ([discrim_var], matching_code) ->
returnDs ( mkCoLetAny (NonRec discrim_var core_discrim) matching_code )
dsExpr (ListComp expr quals)
= putSrcLocDs src_loc $
panic "dsExpr:HsDoOut"
+dsExpr (HsIf guard_expr then_expr else_expr src_loc)
+ = putSrcLocDs src_loc $
+ dsExpr guard_expr `thenDs` \ core_guard ->
+ dsExpr then_expr `thenDs` \ core_then ->
+ dsExpr else_expr `thenDs` \ core_else ->
+ returnDs (mkCoreIfThenElse core_guard core_then core_else)
+
+\end{code}
+
+
+Type lambda and application
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+\begin{code}
+dsExpr (TyLam tyvars expr)
+ = dsExpr expr `thenDs` \ core_expr ->
+ returnDs (mkTyLam tyvars core_expr)
+
+dsExpr expr@(TyApp e tys) = dsApp expr []
+\end{code}
+
+
+Various data construction things
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+\begin{code}
dsExpr (ExplicitListOut ty xs)
= case xs of
[] -> returnDs (mk_nil_con ty)
(map coreExprType core_exprs)
core_exprs
-dsExpr (RecordCon con rbinds) = panic "dsExpr:RecordCon"
-dsExpr (RecordUpd aexp rbinds) = panic "dsExpr:RecordUpd"
-
-dsExpr (HsIf guard_expr then_expr else_expr src_loc)
- = putSrcLocDs src_loc $
- dsExpr guard_expr `thenDs` \ core_guard ->
- dsExpr then_expr `thenDs` \ core_then ->
- dsExpr else_expr `thenDs` \ core_else ->
- returnDs (mkCoreIfThenElse core_guard core_then core_else)
+dsExpr (HsCon con tys args)
+ = mapDs dsExpr args `thenDs` \ args_exprs ->
+ mkConDs con tys args_exprs
dsExpr (ArithSeqOut expr (From from))
= dsExpr expr `thenDs` \ expr2 ->
mkAppDs expr2 [] [from2, thn2, two2]
\end{code}
+Record construction and update
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For record construction we do this (assuming T has three arguments)
-Type lambda and application
-~~~~~~~~~~~~~~~~~~~~~~~~~~~
-\begin{code}
-dsExpr (TyLam tyvars expr)
- = dsExpr expr `thenDs` \ core_expr ->
- returnDs (mkTyLam tyvars core_expr)
+ T { op2 = e }
+==>
+ let err = /\a -> recConErr a
+ T (recConErr t1 "M.lhs/230/op1")
+ e
+ (recConErr t1 "M.lhs/230/op3")
-dsExpr expr@(TyApp e tys) = dsApp expr []
-\end{code}
+recConErr then converts its arugment string into a proper message
+before printing it as
+
+ M.lhs, line 230: missing field op1 was evaluated
-Record construction and update
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
\begin{code}
-{-
dsExpr (RecordCon con_expr rbinds)
= dsExpr con_expr `thenDs` \ con_expr' ->
let
- con_args = map mk_arg (arg_tys `zip` fieldLabelTags)
- (arg_tys, data_ty) = splitFunTy (coreExprType con_expr')
+ con_id = get_con_id con_expr'
+ (arg_tys, data_ty) = splitFunTy (idType con_id)
- mk_arg (arg_ty, tag) = case [ | (sel_id,rhs) <- rbinds,
- fieldLabelTag (recordSelectorFieldLabel sel_id) == tag
+ mk_arg (arg_ty, lbl) = case [rhs | (sel_id,rhs,_) <- rbinds,
+ lbl == recordSelectorFieldLabel sel_id
] of
(rhs:rhss) -> ASSERT( null rhss )
dsExpr rhs
- [] -> returnDs ......GONE HOME!>>>>>
+ [] -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (showForErr lbl)
+ in
+ mapDs mk_arg (arg_tys `zip` dataConFieldLabels con_id) `thenDs` \ con_args ->
- mkAppDs con_expr [] con_args
--}
+ mkAppDs con_expr' [] con_args
+ where
+ -- The "con_expr'" is simply an application of the constructor Id
+ -- to types and (perhaps) dictionaries. This boring little
+ -- function gets the constructor out.
+ get_con_id (App fun _) = get_con_id fun
+ get_con_id (Var con) = con
+\end{code}
+
+Record update is a little harder. Suppose we have the decl:
+
+ data T = T1 {op1, op2, op3 :: Int}
+ | T2 {op4, op1 :: Int}
+ | T3
+
+Then we translate as follows:
+
+ r { op2 = e }
+===>
+ let op2 = e in
+ case r of
+ T1 op1 _ op3 -> T1 op1 op2 op3
+ T2 op4 _ -> T2 op4 op2
+ other -> recUpdError "M.lhs/230"
+
+It's important that we use the constructor Ids for T1, T2 etc on the
+RHSs, and do not generate a Core Con directly, because the constructor
+might do some argument-evaluation first; and may have to throw away some
+dictionaries.
+
+\begin{code}
+dsExpr (RecordUpdOut record_expr dicts rbinds)
+ = dsExpr record_expr `thenDs` \ record_expr' ->
+
+ -- Desugar the rbinds, and generate let-bindings if
+ -- necessary so that we don't lose sharing
+-- dsRbinds rbinds $ \ rbinds' ->
+ let rbinds' = panic "dsExpr:RecordUpdOut:rbinds'" in
+ let
+ record_ty = coreExprType record_expr'
+ (tycon, inst_tys, cons) = getAppDataTyCon record_ty
+ cons_to_upd = filter has_all_fields cons
+
+ -- initial_args are passed to every constructor
+ initial_args = map TyArg inst_tys ++ map VarArg dicts
+
+ mk_val_arg (field, arg_id)
+ = case [arg | (f, arg) <- rbinds', f==field] of
+ (arg:args) -> ASSERT(null args)
+ arg
+ [] -> VarArg arg_id
+
+ mk_alt con
+ = newSysLocalsDs (dataConArgTys con inst_tys) `thenDs` \ arg_ids ->
+ let
+ val_args = map mk_val_arg (dataConFieldLabels con `zipEqual` arg_ids)
+ in
+ returnDs (con, arg_ids, mkGenApp (mkGenApp (Var con) initial_args) val_args)
+
+ mk_default
+ | length cons_to_upd == length cons
+ = returnDs NoDefault
+ | otherwise
+ = newSysLocalDs record_ty `thenDs` \ deflt_id ->
+ mkErrorAppDs rEC_UPD_ERROR_ID record_ty "" `thenDs` \ err ->
+ returnDs (BindDefault deflt_id err)
+ in
+ mapDs mk_alt cons_to_upd `thenDs` \ alts ->
+ mk_default `thenDs` \ deflt ->
+
+ returnDs (Case record_expr' (AlgAlts alts deflt))
+
+ where
+ has_all_fields :: Id -> Bool
+ has_all_fields con_id
+ = all ok rbinds
+ where
+ con_fields = dataConFieldLabels con_id
+ ok (sel_id, _, _) = recordSelectorFieldLabel sel_id `elem` con_fields
\end{code}
Dictionary lambda and application
sep a@(UsageArg _) _ = panic "DsExpr:apply_to_args:UsageArg"
\end{code}
+
+\begin{code}
+dsRbinds :: TypecheckedRecordBinds -- The field bindings supplied
+ -> ([(Id, CoreArg)] -> DsM CoreExpr) -- A continuation taking the field
+ -- bindings with atomic rhss
+ -> DsM CoreExpr -- The result of the continuation,
+ -- wrapped in suitable Lets
+
+dsRbinds [] continue_with
+ = continue_with []
+
+dsRbinds ((sel_id, rhs, pun_flag) : rbinds) continue_with
+ = dsExpr rhs `thenDs` \ rhs' ->
+ dsExprToAtom rhs' $ \ rhs_atom ->
+ dsRbinds rbinds $ \ rbinds' ->
+ continue_with ((panic "dsRbinds:field_label?"{-sel_id-}, rhs_atom) : rbinds')
+\end{code}
+
\begin{code}
do_unfold ty_env val_env (Lam (TyBinder tyvar) body) (TyArg ty : args)
= do_unfold (addOneToTyVarEnv ty_env tyvar ty) val_env body args
import DsMonad
import DsUtils
-import CoreUtils ( escErrorMsg, mkErrorApp, mkCoreIfThenElse )
-import PrelInfo ( stringTy )
+import CoreUtils ( mkCoreIfThenElse )
+import PrelInfo ( stringTy, nON_EXHAUSTIVE_GUARDS_ERROR_ID )
import PprStyle ( PprStyle(..) )
import Pretty ( ppShow )
import SrcLoc ( SrcLoc{-instance-} )
\begin{code}
dsGuarded :: TypecheckedGRHSsAndBinds
- -> SrcLoc
-> DsM CoreExpr
-dsGuarded (GRHSsAndBindsOut grhss binds err_ty) err_loc
+dsGuarded (GRHSsAndBindsOut grhss binds err_ty)
= dsBinds binds `thenDs` \ core_binds ->
dsGRHSs err_ty PatBindMatch [] grhss `thenDs` \ (MatchResult can_it_fail _ core_grhss_fn _) ->
case can_it_fail of
CantFail -> returnDs (mkCoLetsAny core_binds (core_grhss_fn (panic "It can't fail")))
- CanFail -> newSysLocalDs stringTy `thenDs` \ str_var -> -- to hold the String
- returnDs (mkCoLetsAny core_binds (core_grhss_fn (error_expr str_var)))
- where
- unencoded_part_of_msg = escErrorMsg (ppShow 80 (ppr PprForUser err_loc))
-
- error_expr :: Id -> CoreExpr
- error_expr str_var = mkErrorApp err_ty str_var
- (unencoded_part_of_msg
- ++ "%N") --> ": non-exhaustive guards"
+ CanFail -> mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID err_ty "" `thenDs` \ error_expr ->
+ returnDs (mkCoLetsAny core_binds (core_grhss_fn error_expr))
\end{code}
Desugar a list of (grhs, expr) pairs [grhs = guarded
combineMatchResults,
dsExprToAtom,
mkCoAlgCaseMatchResult,
- mkAppDs, mkConDs, mkPrimDs,
+ mkAppDs, mkConDs, mkPrimDs, mkErrorAppDs,
mkCoLetsMatchResult,
mkCoPrimCaseMatchResult,
mkFailurePair,
mkSelectorBinds,
mkTupleBind,
mkTupleExpr,
- selectMatchVars
+ selectMatchVars,
+ showForErr
) where
import Ubiq
import DsMonad
-import CoreUtils ( coreExprType, escErrorMsg, mkCoreIfThenElse, mkErrorApp )
-import PrelInfo ( stringTy )
-import Id ( idType, getInstantiatedDataConSig, mkTupleCon,
+import CoreUtils ( coreExprType, mkCoreIfThenElse )
+import PprStyle ( PprStyle(..) )
+import PrelInfo ( stringTy, iRREFUT_PAT_ERROR_ID )
+import Pretty ( ppShow )
+import Id ( idType, dataConArgTys, mkTupleCon,
DataCon(..), DictVar(..), Id(..), GenId )
+import Literal ( Literal(..) )
import TyCon ( mkTupleTyCon )
import Type ( mkTyVarTys, mkRhoTy, mkFunTys, isUnboxedType,
applyTyCon, getAppDataTyCon
-- We need to build new locals for the args of the constructor,
-- and figuring out their types is somewhat tiresome.
let
- (_,arg_tys,_) = getInstantiatedDataConSig con tycon_arg_tys
+ arg_tys = dataConArgTys con tycon_arg_tys
in
newSysLocalsDs arg_tys `thenDs` \ arg_ids ->
%* *
%************************************************************************
-Plumb the desugarer's @UniqueSupply@ in/out of the @UniqSupply@ monad
-world.
\begin{code}
mkAppDs :: CoreExpr -> [Type] -> [CoreExpr] -> DsM CoreExpr
mkConDs :: Id -> [Type] -> [CoreExpr] -> DsM CoreExpr
returnDs (mkPrim op [] tys vals)
\end{code}
+\begin{code}
+showForErr :: Outputable a => a -> String -- Boring but useful
+showForErr thing = ppShow 80 (ppr PprForUser thing)
+
+mkErrorAppDs :: Id -- The error function
+ -> Type -- Type to which it should be applied
+ -> String -- The error message string to pass
+ -> DsM CoreExpr
+
+mkErrorAppDs err_id ty msg
+ = getSrcLocDs `thenDs` \ (file, line) ->
+ let
+ full_msg = file ++ "|" ++ line ++ "|" ++msg
+ msg_lit = NoRepStr (_PK_ full_msg)
+ in
+ returnDs (mkApp (Var err_id) [] [ty] [LitArg msg_lit])
+\end{code}
+
%************************************************************************
%* *
\subsection[mkSelectorBind]{Make a selector bind}
-> DsM [(Id,CoreExpr)]
mkSelectorBinds tyvars pat locals_and_globals val_expr
- = getSrcLocDs `thenDs` \ (src_file, src_line) ->
-
- if is_simple_tuple_pat pat then
+ = if is_simple_tuple_pat pat then
mkTupleBind tyvars [] locals_and_globals val_expr
else
- newSysLocalDs stringTy `thenDs` \ str_var -> -- to hold the string
- let
- src_loc_str = escErrorMsg ('"' : src_file) ++ "%l" ++ src_line
- error_string = src_loc_str ++ "%~" --> ": pattern-match failed on an irrefutable pattern"
- error_msg = mkErrorApp res_ty str_var error_string
- in
+ mkErrorAppDs iRREFUT_PAT_ERROR_ID res_ty "" `thenDs` \ error_msg ->
matchSimply val_expr pat res_ty local_tuple error_msg `thenDs` \ tuple_expr ->
mkTupleBind tyvars [] locals_and_globals tuple_expr
where
import DsHsSyn ( outPatType, collectTypedPatBinders )
import CoreSyn
+import CoreUtils ( coreExprType )
import DsMonad
import DsGRHSs ( dsGRHSs )
import DsUtils
import MatchCon ( matchConFamily )
import MatchLit ( matchLiterals )
-import CoreUtils ( escErrorMsg, mkErrorApp )
import FieldLabel ( allFieldLabelTags, fieldLabelTag )
import Id ( idType, mkTupleCon, dataConSig,
- recordSelectorFieldLabel,
+ dataConArgTys, recordSelectorFieldLabel,
GenId{-instance-}
)
import PprStyle ( PprStyle(..) )
integerTy, intPrimTy, charPrimTy,
floatPrimTy, doublePrimTy, stringTy,
addrTy, addrPrimTy, addrDataCon,
- wordTy, wordPrimTy, wordDataCon )
+ wordTy, wordPrimTy, wordDataCon,
+ pAT_ERROR_ID
+ )
import Type ( isPrimType, eqTy, getAppDataTyCon,
instantiateTauTy
)
tidy1 v (RecPat con_id pat_ty rpats) match_result
= returnDs (ConPat con_id pat_ty pats, match_result)
where
- pats = map mk_pat tagged_arg_tys
+ pats = map mk_pat tagged_arg_tys
-- Boring stuff to find the arg-tys of the constructor
- (tyvars, _, arg_tys, _) = dataConSig con_id
- (_, inst_tys, _) = getAppDataTyCon pat_ty
- tenv = tyvars `zip` inst_tys
- con_arg_tys' = map (instantiateTauTy tenv) arg_tys
- tagged_arg_tys = con_arg_tys' `zip` allFieldLabelTags
+ (_, inst_tys, _) = getAppDataTyCon pat_ty
+ con_arg_tys' = dataConArgTys con_id inst_tys
+ tagged_arg_tys = con_arg_tys' `zip` allFieldLabelTags
-- mk_pat picks a WildPat of the appropriate type for absent fields,
-- and the specified pattern for present fields
matchWrapper kind matches error_string
= flattenMatches kind matches `thenDs` \ eqns_info@(EqnInfo arg_pats (MatchResult _ result_ty _ _) : _) ->
- selectMatchVars arg_pats `thenDs` \ new_vars ->
- match new_vars eqns_info [] `thenDs` \ match_result ->
+ selectMatchVars arg_pats `thenDs` \ new_vars ->
+ match new_vars eqns_info [] `thenDs` \ match_result ->
+
+ mkErrorAppDs pAT_ERROR_ID result_ty error_string `thenDs` \ fail_expr ->
+ extractMatchResult match_result fail_expr `thenDs` \ result_expr ->
- getSrcLocDs `thenDs` \ (src_file, src_line) ->
- newSysLocalDs stringTy `thenDs` \ str_var -> -- to hold the String
- let
- src_loc_str = escErrorMsg ('"' : src_file) ++ "%l" ++ src_line
- fail_expr = mkErrorApp result_ty str_var (src_loc_str++": "++error_string)
- in
- extractMatchResult match_result fail_expr `thenDs` \ result_expr ->
returnDs (new_vars, result_expr)
\end{code}
returnDs (EqnInfo pats (mkCoLetsMatchResult core_binds match_result))
where
pats = reverse pats_so_far -- They've accumulated in reverse order
+
+ flatten_match pats_so_far (SimpleMatch expr)
+ = dsExpr expr `thenDs` \ core_expr ->
+ returnDs (EqnInfo pats
+ (MatchResult CantFail (coreExprType core_expr)
+ (\ ignore -> core_expr)
+ NoMatchContext))
+ -- The NoMatchContext is just a place holder. In a simple match,
+ -- the matching can't fail, so we won't generate an error message.
+ where
+ pats = reverse pats_so_far -- They've accumulated in reverse order
\end{code}
--others:
import Id ( DictVar(..), Id(..), GenId )
-import Outputable
+import Name ( pprNonOp )
+import Outputable ( interpp'SP, ifnotPprForUser,
+ Outputable(..){-instance * (,)-}
+ )
import Pretty
import SrcLoc ( SrcLoc{-instances-} )
--import TyVar ( GenTyVar{-instances-} )
import HsTypes
-- others:
-import Outputable
+import Name ( pprOp, pprNonOp )
+import Outputable ( interppSP, interpp'SP,
+ Outputable(..){-instance * []-}
+ )
import Pretty
import SrcLoc ( SrcLoc )
import Util ( cmpList, panic#{-ToDo:rm eventually-} )
-- others:
import Id ( DictVar(..), GenId, Id(..) )
-import Outputable
+import Name ( isOpLexeme, pprOp )
+import Outputable ( interppSP, interpp'SP, ifnotPprForUser )
import PprType ( pprGenType, pprParendGenType, GenType{-instance-} )
import Pretty
import PprStyle ( PprStyle(..) )
| RecordUpd (HsExpr tyvar uvar id pat)
(HsRecordBinds tyvar uvar id pat)
+ | RecordUpdOut (HsExpr tyvar uvar id pat) -- TRANSLATION
+ [id] -- Dicts needed for construction
+ (HsRecordBinds tyvar uvar id pat)
+
| ExprWithTySig -- signature binding
(HsExpr tyvar uvar id pat)
(PolyType id)
| SingleDict -- a simple special case of Dictionary
id -- local dictionary name
+ | HsCon -- TRANSLATION; a constructor application
+ Id -- used only in the RHS of constructor definitions
+ [GenType tyvar uvar]
+ [HsExpr tyvar uvar id pat]
+
type HsRecordBinds tyvar uvar id pat
= [(id, HsExpr tyvar uvar id pat, Bool)]
-- True <=> source code used "punning",
interface HsLoop where
-import HsExpr( HsExpr )
-import Outputable( NamedThing, Outputable )
-import HsBinds ( Bind, HsBinds, MonoBinds, Sig, nullBinds, nullMonoBinds )
-import HsDecls ( ConDecl )
+import HsExpr ( HsExpr )
+import HsBinds ( Bind, HsBinds, MonoBinds, Sig, nullBinds, nullMonoBinds )
+import HsDecls ( ConDecl )
+import Name ( NamedThing )
+import Outputable ( Outputable )
-- HsExpr outputs
data HsExpr tyvar uvar id pat
= PatMatch pat
(Match tyvar uvar id pat)
| GRHSMatch (GRHSsAndBinds tyvar uvar id pat)
+
+ | SimpleMatch (HsExpr tyvar uvar id pat) -- Used in translations
\end{code}
Sets of guarded right hand sides (GRHSs). In:
-- others:
import Id ( GenId, dataConSig )
import Maybes ( maybeToBool )
-import Outputable
+import Name ( pprOp, pprNonOp )
+import Outputable ( interppSP, interpp'SP, ifPprShowAll )
import PprStyle ( PprStyle(..) )
import Pretty
import TyCon ( maybeTyConSingleCon )
BuiltinKeys(..), BuiltinIdInfos(..),
-- *odd* values that need to be reached out and grabbed:
- eRROR_ID, pAT_ERROR_ID, aBSENT_ERROR_ID,
+ eRROR_ID,
+ pAT_ERROR_ID,
+ rEC_CON_ERROR_ID,
+ rEC_UPD_ERROR_ID,
+ iRREFUT_PAT_ERROR_ID,
+ nON_EXHAUSTIVE_GUARDS_ERROR_ID,
+ aBSENT_ERROR_ID,
packStringForCId,
unpackCStringId, unpackCString2Id,
unpackCStringAppendId, unpackCStringFoldrId,
import FiniteMap ( FiniteMap, emptyFM, listToFM )
import Id ( mkTupleCon, GenId, Id(..) )
import Maybes ( catMaybes )
-import Name ( mkBuiltinName )
-import Outputable ( getOrigName )
+import Name ( mkBuiltinName, getOrigName )
import RnHsSyn ( RnName(..) )
import TyCon ( tyConDataCons, mkFunTyCon, mkTupleTyCon, TyCon )
import Type
eRROR_ID
= pc_bottoming_Id errorIdKey pRELUDE_BUILTIN SLIT("error") errorTy
+generic_ERROR_ID u n
+ = pc_bottoming_Id u pRELUDE_BUILTIN n errorTy
+
pAT_ERROR_ID
- = pc_bottoming_Id patErrorIdKey pRELUDE_BUILTIN SLIT("patError#") errorTy
+ = generic_ERROR_ID patErrorIdKey SLIT("patError#")
+rEC_CON_ERROR_ID
+ = generic_ERROR_ID recConErrorIdKey SLIT("recConError#")
+rEC_UPD_ERROR_ID
+ = generic_ERROR_ID recUpdErrorIdKey SLIT("recUpdError#")
+iRREFUT_PAT_ERROR_ID
+ = generic_ERROR_ID irrefutPatErrorIdKey SLIT("irrefutPatError#")
+nON_EXHAUSTIVE_GUARDS_ERROR_ID
+ = generic_ERROR_ID nonExhaustiveGuardsErrorIdKey SLIT("nonExhaustiveGuardsError#")
aBSENT_ERROR_ID
= pc_bottoming_Id absentErrorIdKey pRELUDE_BUILTIN SLIT("absent#")
cmpCostCentre -- used for removing dups in a list
) where
+import Ubiq{-uitous-}
+
import Id ( externallyVisibleId, GenId, Id(..) )
import CStrings ( identToC, stringToC )
import Maybes ( Maybe(..) )
-import Name ( showRdr, RdrName )
-import Outputable
+import Name ( showRdr, getOccName, RdrName )
import Pretty ( ppShow, prettyToUn )
import PprStyle ( PprStyle(..) )
import UniqSet
import Unpretty
import Util
-import Ubiq
+
showId = panic "Whoops"
pprIdInUnfolding = panic "Whoops"
\end{code}
opt_SccGroup
)
import CoreSyn
-import Id ( isTopLevId, GenId{-instances-} )
-import Outputable ( isExported )
import CostCentre ( mkAutoCC, IsCafCC(..) )
+import Id ( isTopLevId, GenId{-instances-} )
+import Name ( isExported )
\end{code}
\begin{code}
import Ubiq
import HsSyn
-import Outputable ( ExportFlag(..) )
+import Name ( ExportFlag(..) )
\end{code}
\begin{code}
import Bag ( isEmptyBag, unionBags, bagToList, listToBag )
import ErrUtils ( Error(..), Warning(..) )
import FiniteMap ( emptyFM, eltsFM )
-import Name ( Name, RdrName(..) )
-import Outputable ( getOrigNameRdr, isLocallyDefined )
+import Name ( getOrigNameRdr, isLocallyDefined, Name, RdrName(..) )
import PrelInfo ( BuiltinNames(..), BuiltinKeys(..) )
import UniqFM ( emptyUFM, lookupUFM, addListToUFM_C, eltsUFM )
import UniqSupply ( splitUniqSupply )
= findHiFiles `thenPrimIO` \ hi_files ->
newVar (emptyFM, hi_files) `thenPrimIO` \ iface_var ->
- fixPrimIO ( \ (_, _, _, _, rec_occ_fm, rec_export_fn) ->
+ fixPrimIO ( \ ~(_, _, _, _, rec_occ_fm, rec_export_fn) ->
let
rec_occ_fn :: Name -> [RdrName]
rec_occ_fn n = case lookupUFM rec_occ_fm n of
import RnMonad
import ErrUtils ( addErrLoc )
-import Name ( isLocallyDefinedName, Name, RdrName )
-import Outputable ( pprOp )
+import Name ( isLocallyDefinedName, pprOp, Name, RdrName )
import Pretty
import UniqFM ( lookupUFM )
import UniqSet ( emptyUniqSet, unitUniqSet,
import HsSyn
-import Name ( isLocalName, nameUnique, Name, RdrName )
import Id ( GenId, Id(..) )
-import Outputable ( Outputable(..) )
-import PprType ( GenType, GenTyVar, TyCon )
+import Name ( isLocalName, nameUnique, Name, RdrName )
+import Outputable ( Outputable(..){-instance * []-} )
import PprStyle ( PprStyle(..) )
+import PprType ( GenType, GenTyVar, TyCon )
import Pretty
import TyCon ( TyCon )
import TyVar ( GenTyVar )
import FiniteMap ( FiniteMap, emptyFM, lookupFM, addToFM )
import Maybes ( assocMaybe )
import Name ( Module(..), RdrName(..), isQual,
- Name, mkLocalName, mkImplicitName
+ Name, mkLocalName, mkImplicitName,
+ getOccName
)
-import Outputable ( getOccName )
-import PprStyle ( PprStyle )
import Pretty ( Pretty(..), PrettyRep )
import SrcLoc ( SrcLoc, mkUnknownSrcLoc )
import UniqFM ( UniqFM, emptyUFM )
import Bag ( emptyBag, unitBag, unionBags, unionManyBags, mapBag, listToBag, bagToList )
import ErrUtils ( Error(..), Warning(..), addShortErrLocLine )
import FiniteMap ( fmToList )
-import Name ( RdrName(..), isQual, mkTopLevName, mkImportedName, nameExportFlag, Name )
-import Outputable ( getLocalName, getSrcLoc, pprNonOp )
+import Name ( RdrName(..), Name, isQual, mkTopLevName,
+ mkImportedName, nameExportFlag,
+ getLocalName, getSrcLoc, pprNonOp
+ )
import PrelInfo ( BuiltinNames(..), BuiltinKeys(..) )
import PrelMods ( fromPrelude )
import Pretty
import Bag ( bagToList )
import Class ( derivableClassKeys )
import ListSetOps ( unionLists, minusList )
-import Name ( RdrName )
import Maybes ( maybeToBool, catMaybes )
-import Outputable ( isLocallyDefined, isAvarid, getLocalName, ExportFlag(..) )
+import Name ( isLocallyDefined, isAvarid, getLocalName, ExportFlag(..), RdrName )
import Pretty
import SrcLoc ( SrcLoc )
import Unique ( Unique )
import FiniteMap ( FiniteMap, emptyFM, isEmptyFM,
lookupFM, addListToFM, addToFM )
import Maybes ( maybeToBool )
-import Name ( RdrName(..), isQual )
-import Outputable ( pprNonOp, getLocalName )
+import Name ( RdrName(..), isQual, pprNonOp, getLocalName )
import PprStyle ( PprStyle(..) )
import Pretty
import RnHsSyn ( RnName )
GenId{-instance Eq-}
)
import Maybes ( maybeToBool )
-import Outputable ( isExported, Outputable(..){-instance * (,) -} )
+import Name ( isExported )
+import Outputable ( Outputable(..){-instance * (,) -} )
import PprCore
import PprStyle ( PprStyle(..) )
import PprType ( GenType{-instance Outputable-}, GenTyVar{-ditto-} )
-- tag (or Exported tag) modified.
fake_binder = mkSysLocal
(getOccName binder _APPEND_ SLIT("_fsat"))
- (getItsUnique binder)
+ (uniqueOf binder)
(idType binder)
mkUnknownSrcLoc
rec_body = mkValLam non_static_args
IdEnv(..), IdSet(..), GenId )
import IdInfo ( StrictnessInfo )
import Literal ( isNoRepLit, Literal{-instances-} )
-import Outputable ( isLocallyDefined, Outputable(..){-instances-} )
+import Name ( isLocallyDefined )
+import Outputable ( Outputable(..){-instances-} )
import PprCore -- various instances
import PprStyle ( PprStyle(..) )
import PprType ( GenType, GenTyVar )
GenId{-instance Ord3-}
)
import Maybes ( catMaybes )
+import Name ( isExported )
import OccurAnal ( occurAnalyseBinds )
-import Outputable ( isExported )
import Pretty ( ppAboves, ppBesides, ppInt, ppChar, ppStr )
import SimplEnv
import SimplMonad
import CmdLineOpts ( SimplifierSwitch(..) )
import CoreSyn
import CoreUtils ( manifestlyWHNF )
-import Id ( idType, isBottomingId, idWantsToBeINLINEd,
+import Id ( idType, isBottomingId, idWantsToBeINLINEd, dataConArgTys,
getIdArity, GenId{-instance Eq-}
)
import IdInfo ( arityMaybe )
import TyVar ( GenTyVar{-instance Eq-} )
import Util ( isIn, panic )
-getInstantiatedDataConSig = panic "SimplUtils.getInstantiatedDataConSig (ToDo)"
\end{code}
= case (maybeAppDataTyCon rhs_ty) of
Just (tycon, ty_args, [data_con]) -> -- algebraic type suitable for unpacking
let
- (_,inst_con_arg_tys,_) = getInstantiatedDataConSig data_con ty_args
+ inst_con_arg_tys = dataConArgTys data_con ty_args
in
newIds inst_con_arg_tys `thenSmpl` \ new_bindees ->
let
import IdInfo ( willBeDemanded, DemandInfo )
import Literal ( isNoRepLit )
import Maybes ( maybeToBool )
-import Outputable ( isLocallyDefined )
+import Name ( isLocallyDefined )
import PprStyle ( PprStyle(..) )
import PprType ( GenType{-instance Outputable-} )
import PrelInfo ( realWorldStateTy )
import StgUtils
import LambdaLift ( liftProgram )
-import Outputable ( isLocallyDefined )
+import Name ( isLocallyDefined )
import SCCfinal ( stgMassageForProfiling )
import SatStgRhs ( satStgRhs )
import StgLint ( lintStgBindings )
)
import MainMonad ( writeMn, thenMn_, thenMn, returnMn, MainIO(..) )
import Maybes ( maybeToBool )
-import Outputable ( isExported )
+import Name ( isExported )
import PprType ( GenType{-instance Outputable-} )
import Pretty ( ppShow, ppAbove, ppAboves, ppStr )
import UniqSupply ( splitUniqSupply )
GenId{-instance Eq-}
)
import Maybes ( maybeToBool )
-import Outputable ( isLocallyDefined )
+import Name ( isLocallyDefined )
import PprStyle ( PprStyle(..) )
import PprType ( GenType{-instance Outputable-} )
import Util ( panic, pprPanic, assertPanic )
GenId {-instance NamedThing -}
)
import Maybes ( maybeToBool, catMaybes, firstJust )
-import Outputable ( isAvarop, pprNonOp, getOrigName )
+import Name ( isAvarop, pprNonOp, getOrigName )
import PprStyle ( PprStyle(..) )
import PprType ( pprGenType, pprParendGenType, pprMaybeTy,
TyCon{-ditto-}, GenType{-ditto-}, GenTyVar
)
import Literal ( Literal{-instance Outputable-} )
import Maybes ( catMaybes, firstJust, maybeToBool )
-import Outputable ( interppSP, isLocallyDefined, Outputable(..){-instance * []-} )
+import Name ( isLocallyDefined )
+import Outputable ( interppSP, Outputable(..){-instance * []-} )
import PprStyle ( PprStyle(..) )
import PprType ( pprGenType, pprParendGenType, pprMaybeTy,
GenType{-instance Outputable-}, GenTyVar{-ditto-},
IdEnv(..), GenId{-instance NamedThing-}
)
import Literal ( mkMachInt, Literal(..) )
-import Outputable ( isExported )
+import Name ( isExported )
import PrelInfo ( unpackCStringId, unpackCString2Id, stringTy,
integerTy, rationalTy, ratioDataCon,
integerZeroId, integerPlusOneId,
import StgSyn
import Bag ( emptyBag, isEmptyBag, snocBag, foldBag )
-import Id ( idType, isDataCon,
+import Id ( idType, isDataCon, dataConArgTys,
emptyIdSet, isEmptyIdSet, elementOfIdSet,
mkIdSet, intersectIdSets,
unionIdSets, idSetToList, IdSet(..),
)
import Literal ( literalType, Literal{-instance Outputable-} )
import Maybes ( catMaybes )
-import Outputable ( Outputable(..){-instance * []-},
- isLocallyDefined, getSrcLoc
- )
+import Name ( isLocallyDefined, getSrcLoc )
+import Outputable ( Outputable(..){-instance * []-} )
import PprType ( GenType{-instance Outputable-}, TyCon )
import Pretty -- quite a bit of it
import PrimOp ( primOpType )
infixr 9 `thenL`, `thenL_`, `thenMaybeL`, `thenMaybeL_`
-getInstantiatedDataConSig = panic "StgLint.getInstantiatedDataConSig (ToDo)"
splitTypeWithDictsAsArgs = panic "StgLint.splitTypeWithDictsAsArgs (ToDo)"
unDictifyTy = panic "StgLint.unDictifyTy (ToDo)"
\end{code}
addErrL (mkAlgAltMsg1 scrut_ty)
Just (tycon, tys_applied, cons) ->
let
- (_, arg_tys, _) = getInstantiatedDataConSig con tys_applied
+ arg_tys = dataConArgTys con tys_applied
in
checkL (con `elem` cons) (mkAlgAltMsg2 scrut_ty con) `thenL_`
checkL (length arg_tys == length args) (mkAlgAltMsg3 con args)
import CostCentre ( showCostCentre )
import Id ( idPrimRep, GenId{-instance NamedThing-} )
import Literal ( literalPrimRep, isLitLitLit, Literal{-instance Outputable-} )
-import Outputable ( isExported, isOpLexeme, ifPprDebug,
- interppSP, interpp'SP,
+import Name ( isExported, isOpLexeme )
+import Outputable ( ifPprDebug, interppSP, interpp'SP,
Outputable(..){-instance * Bool-}
)
import PprStyle ( PprStyle(..) )
import CoreUnfold ( UnfoldingDetails(..), FormSummary )
import CoreUtils ( unTagBinders )
import Id ( idType, getIdStrictness, getIdUnfolding,
- dataConSig
+ dataConSig, dataConArgTys
)
import IdInfo ( StrictnessInfo(..), Demand(..),
wwPrim, wwStrict, wwEnum, wwUnpack
pprTrace, panic, pprPanic, assertPanic
)
-getInstantiatedDataConSig = panic "SaAbsInt.getInstantiatedDataConSig (ToDo)"
returnsRealWorld = panic "SaAbsInt.returnsRealWorld (ToDo)"
\end{code}
Just (tycon,tycon_arg_tys,[data_con]) | tycon `not_elem` seen ->
-- Single constructor case, tycon not already seen higher up
let
- (_,cmpnt_tys,_) = getInstantiatedDataConSig data_con tycon_arg_tys
+ cmpnt_tys = dataConArgTys data_con tycon_arg_tys
prod_len = length cmpnt_tys
compt_strict_infos
import Ubiq{-uitous-}
import CoreSyn
-import Id ( idType, mkSysLocal )
+import Id ( idType, mkSysLocal, dataConArgTys )
import IdInfo ( mkStrictnessInfo, nonAbsentArgs, Demand(..) )
import PrelInfo ( aBSENT_ERROR_ID )
import SrcLoc ( mkUnknownSrcLoc )
import Util ( zipWithEqual, assertPanic, panic )
quantifyTy = panic "WwLib.quantifyTy"
-getInstantiatedDataConSig = panic "WwLib.getInstantiatedDataConSig"
\end{code}
%************************************************************************
-- The main event: a single-constructor data type
let
- (_,inst_con_arg_tys,_)
- = getInstantiatedDataConSig data_con tycon_arg_tys
+ inst_con_arg_tys = dataConArgTys data_con tycon_arg_tys
in
getUniques (length inst_con_arg_tys) `thenUs` \ uniqs ->
import Class ( Class(..), GenClass, ClassInstEnv(..), getClassInstEnv )
import Id ( GenId, idType, mkInstId )
import MatchEnv ( lookupMEnv, insertMEnv )
-import Name ( mkLocalName, Name )
+import Name ( mkLocalName, getLocalName, Name )
import Outputable
import PprType ( GenClass, TyCon, GenType, GenTyVar )
import PprStyle ( PprStyle(..) )
= OccurrenceOf (TcIdOcc s) -- Occurrence of an overloaded identifier
| OccurrenceOfCon Id -- Occurrence of a data constructor
+ | RecordUpdOrigin
+
+ | DataDeclOrigin -- Typechecking a data declaration
+
| InstanceDeclOrigin -- Typechecking an instance decl
| LiteralOrigin HsLit -- Occurrence of a literal
import Id ( GenId, idType, mkUserId )
import IdInfo ( noIdInfo )
import Maybes ( assocMaybe, catMaybes, Maybe(..) )
-import Outputable ( pprNonOp )
+import Name ( pprNonOp )
import PragmaInfo ( PragmaInfo(..) )
import Pretty
import RnHsSyn ( RnName ) -- instances
RecBind _ -> mkTypeKind -- Non-recursive, so we permit unboxed types
\end{code}
+
+===========
+\begin{code}
+{-
+
+data SigInfo
+ = SigInfo RnName
+ (TcIdBndr s) -- Polymorpic version
+ (TcIdBndr s) -- Monomorphic verstion
+ [TcType s] [TcIdOcc s] -- Instance information for the monomorphic version
+
+
+
+ -- Deal with type signatures
+ tcTySigs sigs `thenTc` \ sig_infos ->
+ let
+ sig_binders = [binder | SigInfo binder _ _ _ _ <- sig_infos]
+ poly_sigs = [(name,poly) | SigInfo name poly _ _ _ <- sig_infos]
+ mono_sigs = [(name,mono) | SigInfo name _ mono _ _ <- sig_infos]
+ nosig_binders = binders `minusList` sig_binders
+ in
+
+
+ -- Typecheck the binding group
+ tcExtendLocalEnv poly_sigs (
+ newMonoIds nosig_binders kind (\ nosig_local_ids ->
+ tcMonoBinds mono_sigs mono_binds `thenTc` \ binds_w_lies ->
+ returnTc (nosig_local_ids, binds_w_lies)
+ )) `thenTc` \ (nosig_local_ids, binds_w_lies) ->
+
+
+ -- Decide what to generalise over
+ getImplicitStuffToGen sig_ids binds_w_lies
+ `thenTc` \ (tyvars_not_to_gen, tyvars_to_gen, lie_to_gen) ->
+
+
+ -- Make poly_ids for all the binders that don't have type signatures
+ let
+ dicts_to_gen = map instToId (bagToList lie_to_gen)
+ dict_tys = map tcIdType dicts_to_gen
+
+ mk_poly binder local_id = mkUserId (getName binder) ty noPragmaInfo
+ where
+ ty = mkForAllTys tyvars_to_gen $
+ mkFunTys dict_tys $
+ tcIdType local_id
+
+ tys_to_gen = mkTyVarTys tyvars_to_gen
+ more_sig_infos = [ SigInfo binder (mk_poly binder local_id)
+ local_id tys_to_gen dicts_to_gen lie_to_gen
+ | (binder, local_id) <- nosig_binders `zipEqual` nosig_local_ids
+ ]
+
+ local_binds = [ (local_id, DictApp (mkHsTyApp (HsVar local_id) inst_tys) dicts)
+ | SigInfo _ _ local_id inst_tys dicts <- more_sig_infos
+ ]
+
+ all_sig_infos = sig_infos ++ more_sig_infos -- Contains a "signature" for each binder
+ in
+
+
+ -- Now generalise the bindings
+ let
+ find_sig lid = head [ (pid, tvs, ds, lie)
+ | SigInfo _ pid lid' tvs ds lie,
+ lid==lid'
+ ]
+ -- Do it again, but with increased free_tyvars/reduced_tyvars_to_gen:
+ -- We still need to do this simplification, because some dictionaries
+ -- may gratuitously constrain some tyvars over which we *are* going
+ -- to generalise.
+ -- For example d::Eq (Foo a b), where Foo is instanced as above.
+ gen_bind (bind, lie)
+ = tcSimplifyWithExtraGlobals tyvars_not_to_gen tyvars_to_gen avail lie
+ `thenTc` \ (lie_free, dict_binds) ->
+ returnTc (AbsBind tyvars_to_gen_here
+ dicts
+ (local_ids `zipEqual` poly_ids)
+ (dict_binds ++ local_binds)
+ bind,
+ lie_free)
+ where
+ local_ids = bindersOf bind
+ local_sigs = [sig | sig@(SigInfo _ _ local_id _ _) <- all_sig_infos,
+ local_id `elem` local_ids
+ ]
+
+ (tyvars_to_gen_here, dicts, avail)
+ = case (local_ids, sigs) of
+
+ ([local_id], [SigInfo _ _ _ tyvars_to_gen dicts lie])
+ -> (tyvars_to_gen, dicts, lie)
+
+ other -> (tyvars_to_gen, dicts, avail)
+\end{code}
+
+@getImplicitStuffToGen@ decides what type variables
+and LIE to generalise over.
+
+For a "restricted group" -- see the monomorphism restriction
+for a definition -- we bind no dictionaries, and
+remove from tyvars_to_gen any constrained type variables
+
+*Don't* simplify dicts at this point, because we aren't going
+to generalise over these dicts. By the time we do simplify them
+we may well know more. For example (this actually came up)
+ f :: Array Int Int
+ f x = array ... xs where xs = [1,2,3,4,5]
+We don't want to generate lots of (fromInt Int 1), (fromInt Int 2)
+stuff. If we simplify only at the f-binding (not the xs-binding)
+we'll know that the literals are all Ints, and we can just produce
+Int literals!
+
+Find all the type variables involved in overloading, the "constrained_tyvars"
+These are the ones we *aren't* going to generalise.
+We must be careful about doing this:
+ (a) If we fail to generalise a tyvar which is not actually
+ constrained, then it will never, ever get bound, and lands
+ up printed out in interface files! Notorious example:
+ instance Eq a => Eq (Foo a b) where ..
+ Here, b is not constrained, even though it looks as if it is.
+ Another, more common, example is when there's a Method inst in
+ the LIE, whose type might very well involve non-overloaded
+ type variables.
+ (b) On the other hand, we mustn't generalise tyvars which are constrained,
+ because we are going to pass on out the unmodified LIE, with those
+ tyvars in it. They won't be in scope if we've generalised them.
+
+So we are careful, and do a complete simplification just to find the
+constrained tyvars. We don't use any of the results, except to
+find which tyvars are constrained.
+
+\begin{code}
+getImplicitStuffToGen is_restricted sig_ids binds_w_lies
+ | isUnRestrictedGroup tysig_vars bind
+ = tcSimplify tyvars_to_gen lie `thenTc` \ (_, _, dicts_to_gen) ->
+ returnNF_Tc (emptyTyVarSet, tyvars_to_gen, dicts_to_gen)
+
+ | otherwise
+ = tcSimplify tyvars_to_gen lie `thenTc` \ (_, _, constrained_dicts) ->
+ let
+ -- ASSERT: dicts_sig is already zonked!
+ constrained_tyvars = foldBag unionTyVarSets tyVarsOfInst emptyTyVarSet constrained_dicts
+ reduced_tyvars_to_gen = tyvars_to_gen `minusTyVarSet` constrained_tyvars
+ in
+ returnTc (constrained_tyvars, reduced_tyvars_to_gen, emptyLIE)
+
+ where
+ sig_ids = [sig_var | (TySigInfo sig_id _ _ _ _) <- ty_sigs]
+
+ (tyvars_to_gen, lie) = foldBag (\(tv1,lie2) (tv2,lie2) -> (tv1 `unionTyVarSets` tv2,
+ lie1 `plusLIE` lie2))
+ get
+ (emptyTyVarSet, emptyLIE)
+ binds_w_lies
+ get (bind, lie)
+ = case bindersOf bind of
+ [local_id] | local_id `in` sig_ids -> -- A simple binding with
+ -- a type signature
+ (emptyTyVarSet, emptyLIE)
+
+ local_ids -> -- Complex binding or no type sig
+ (foldr (unionTyVarSets . tcIdType) emptyTyVarSet local_ids,
+ lie)
+-}
+\end{code}
+
+
+
\begin{code}
tc_bind :: RenamedBind -> TcM s (TcBind s, LIE s)
import Id ( mkSuperDictSelId, mkMethodSelId, mkDefaultMethodId,
idType )
import IdInfo ( noIdInfo )
-import Outputable ( isLocallyDefined, getOrigName, getLocalName )
+import Name ( isLocallyDefined, getOrigName, getLocalName )
import PrelVals ( pAT_ERROR_ID )
import PprStyle
import Pretty
import ErrUtils ( pprBagOfErrors, addErrLoc, Error(..) )
import Id ( dataConSig, dataConArity )
import Maybes ( assocMaybe, maybeToBool, Maybe(..) )
---import Name ( Name(..) )
import Outputable
import PprType ( GenType, GenTyVar, GenClass, TyCon )
import PprStyle
tcExtendGlobalValEnv, tcExtendLocalValEnv,
tcLookupLocalValue, tcLookupLocalValueOK, tcLookupLocalValueByKey,
- tcLookupGlobalValue, tcLookupGlobalValueByKey, tcGlobalOcc,
+ tcLookupGlobalValue, tcLookupGlobalValueByKey,
newMonoIds, newLocalIds, newLocalId,
tcGetGlobalTyVars
import TcMonad
-import Name ( Name{-instance NamedThing-} )
-import Outputable ( getOccName, getSrcLoc )
+import Name ( getOccName, getSrcLoc, Name{-instance NamedThing-} )
import PprStyle
import Pretty
import RnHsSyn ( RnName(..) )
def = panic "tcLookupGlobalValue"
#endif
--- A useful function that takes an occurrence of a global thing
--- and instantiates its type with fresh type variables
-tcGlobalOcc :: RnName
- -> NF_TcM s (Id, -- The Id
- [TcType s], -- Instance types
- TcType s) -- Rest of its type
-
-tcGlobalOcc name
- = tcLookupGlobalValue name `thenNF_Tc` \ id ->
- let
- (tyvars, rho) = splitForAllTy (idType id)
- in
- tcInstTyVars tyvars `thenNF_Tc` \ (tyvars', arg_tys, tenv) ->
- tcInstType tenv rho `thenNF_Tc` \ rho' ->
- returnNF_Tc (id, arg_tys, rho')
-
-
tcLookupGlobalValueByKey :: Unique -> NF_TcM s Id
tcLookupGlobalValueByKey uniq
= tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
newMethod, newMethodWithGivenTy, newDicts )
import TcBinds ( tcBindsAndThen )
import TcEnv ( tcLookupLocalValue, tcLookupGlobalValue, tcLookupClassByKey,
- tcLookupGlobalValueByKey, newMonoIds, tcGetGlobalTyVars,
- tcGlobalOcc
+ tcLookupGlobalValueByKey, newMonoIds, tcGetGlobalTyVars
)
import TcMatches ( tcMatchesCase, tcMatch )
import TcMonoType ( tcPolyType )
import TcPat ( tcPat )
import TcSimplify ( tcSimplifyAndCheck, tcSimplifyRank2 )
import TcType ( TcType(..), TcMaybe(..),
- tcInstType, tcInstTcType, tcInstTyVars,
+ tcInstId, tcInstType, tcInstTheta, tcInstTcType, tcInstTyVars,
newTyVarTy, zonkTcTyVars, zonkTcType )
import TcKind ( TcKind )
import Class ( Class(..), getClassSig )
import FieldLabel ( fieldLabelName )
-import Id ( Id(..), GenId, idType, dataConFieldLabels )
+import Id ( Id(..), GenId, idType, dataConFieldLabels, dataConSig )
import Kind ( Kind, mkBoxedTypeKind, mkTypeKind, mkArrowKind )
import GenSpecEtc ( checkSigTyVars, checkSigTyVarsGivenGlobals )
import Name ( Name{-instance Eq-} )
getTyVar_maybe, getFunTy_maybe,
splitForAllTy, splitRhoTy, splitSigmaTy, splitFunTy,
isTauTy, mkFunTys, tyVarsOfType, getForAllTy_maybe,
- maybeAppDataTyCon
+ getAppDataTyCon, maybeAppDataTyCon
)
import TyVar ( GenTyVar, TyVarSet(..), unionTyVarSets, mkTyVarSet )
import Unify ( unifyTauTy, unifyTauTyList, unifyTauTyLists, unifyFunTy )
\begin{code}
tcExpr (HsVar name)
- = tcId name `thenTc` \ (expr', lie, res_ty) ->
+ = tcId name `thenNF_Tc` \ (expr', lie, res_ty) ->
-- Check that the result type doesn't have any nested for-alls.
-- For example, a "build" on its own is no good; it must be
returnTc (ExplicitTuple exprs', lie, mkTupleTy (length tys) tys)
tcExpr (RecordCon (HsVar con) rbinds)
- = tcGlobalOcc con `thenNF_Tc` \ (con_id, arg_tys, con_rho) ->
+ = tcId con `thenNF_Tc` \ (con_expr, con_lie, con_tau) ->
let
- (con_theta, con_tau) = splitRhoTy con_rho
(_, record_ty) = splitFunTy con_tau
- con_expr = mkHsTyApp (HsVar (RealId con_id)) arg_tys
in
- -- TEMPORARY ASSERT
- ASSERT( null con_theta )
-
-- Con is syntactically constrained to be a data constructor
ASSERT( maybeToBool (maybeAppDataTyCon record_ty ) )
tcRecordBinds record_ty rbinds `thenTc` \ (rbinds', rbinds_lie) ->
+ -- Check that the record bindings match the constructor
+ tcLookupGlobalValue con `thenNF_Tc` \ con_id ->
checkTc (checkRecordFields rbinds con_id)
(badFieldsCon con rbinds) `thenTc_`
- returnTc (RecordCon con_expr rbinds', panic "tcExpr:RecordCon:con_lie???" {-con_lie???-} `plusLIE` rbinds_lie, record_ty)
+ returnTc (RecordCon con_expr rbinds', con_lie `plusLIE` rbinds_lie, record_ty)
+
+-- One small complication in RecordUpd is that we have to generate some
+-- dictionaries for the data type context, since we are going to
+-- do some construction.
+--
+-- What dictionaries do we need? For the moment we assume that all
+-- data constructors have the same context, and grab it from the first
+-- constructor. If they have varying contexts then we'd have to
+-- union the ones that could participate in the update.
tcExpr (RecordUpd record_expr rbinds)
- = tcExpr record_expr `thenTc` \ (record_expr', record_lie, record_ty) ->
+ = ASSERT( not (null rbinds) )
+ tcAddErrCtxt recordUpdCtxt $
+
+ tcExpr record_expr `thenTc` \ (record_expr', record_lie, record_ty) ->
tcRecordBinds record_ty rbinds `thenTc` \ (rbinds', rbinds_lie) ->
-- Check that the field names are plausible
zonkTcType record_ty `thenNF_Tc` \ record_ty' ->
let
- maybe_tycon_stuff = maybeAppDataTyCon record_ty'
- Just (tycon, args_tys, data_cons) = maybe_tycon_stuff
+ (tycon, inst_tys, data_cons) = getAppDataTyCon record_ty'
+ -- The record binds are non-empty (syntax); so at least one field
+ -- label will have been unified with record_ty by tcRecordBinds;
+ -- field labels must be of data type; hencd the getAppDataTyCon must succeed.
+ (tyvars, theta, _, _) = dataConSig (head data_cons)
in
- checkTc (maybeToBool maybe_tycon_stuff)
- (panic "TcExpr:Records:mystery error message") `thenTc_`
+ tcInstTheta (tyvars `zipEqual` inst_tys) theta `thenNF_Tc` \ theta' ->
+ newDicts RecordUpdOrigin theta' `thenNF_Tc` \ (con_lie, dicts) ->
checkTc (any (checkRecordFields rbinds) data_cons)
(badFieldsUpd rbinds) `thenTc_`
- returnTc (RecordUpd record_expr' rbinds', record_lie `plusLIE` rbinds_lie, record_ty)
+
+ returnTc (RecordUpdOut record_expr' dicts rbinds',
+ con_lie `plusLIE` record_lie `plusLIE` rbinds_lie,
+ record_ty)
tcExpr (ArithSeqIn seq@(From expr))
= tcExpr expr `thenTc` \ (expr', lie1, ty) ->
-- In the HsVar case we go straight to tcId to avoid hitting the
-- rank-2 check, which we check later here anyway
(case fun of
- HsVar name -> tcId name
+ HsVar name -> tcId name `thenNF_Tc` \ stuff -> returnTc stuff
other -> tcExpr fun
) `thenTc` \ (fun', lie_fun, fun_ty) ->
%************************************************************************
\begin{code}
-tcId :: RnName -> TcM s (TcExpr s, LIE s, TcType s)
+tcId :: RnName -> NF_TcM s (TcExpr s, LIE s, TcType s)
tcId name
= -- Look up the Id and instantiate its type
tcInstTcType tenv rho `thenNF_Tc` \ rho' ->
returnNF_Tc (TcId tc_id, arg_tys', rho')
- Nothing -> tcGlobalOcc name `thenNF_Tc` \ (id, arg_tys, rho) ->
- returnNF_Tc (RealId id, arg_tys, rho)
+ Nothing -> tcLookupGlobalValue name `thenNF_Tc` \ id ->
+ let
+ (tyvars, rho) = splitForAllTy (idType id)
+ in
+ tcInstTyVars tyvars `thenNF_Tc` \ (tyvars', arg_tys, tenv) ->
+ tcInstType tenv rho `thenNF_Tc` \ rho' ->
+ returnNF_Tc (RealId id, arg_tys, rho')
) `thenNF_Tc` \ (tc_id_occ, arg_tys, rho) ->
-- Is it overloaded?
case splitRhoTy rho of
([], tau) -> -- Not overloaded, so just make a type application
- returnTc (mkHsTyApp (HsVar tc_id_occ) arg_tys, emptyLIE, tau)
+ returnNF_Tc (mkHsTyApp (HsVar tc_id_occ) arg_tys, emptyLIE, tau)
(theta, tau) -> -- Overloaded, so make a Method inst
newMethodWithGivenTy (OccurrenceOf tc_id_occ)
tc_id_occ arg_tys rho `thenNF_Tc` \ (lie, meth_id) ->
- returnTc (HsVar meth_id, lie, tau)
+ returnNF_Tc (HsVar meth_id, lie, tau)
\end{code}
returnTc (rbinds', plusLIEs lies)
where
do_bind (field_label, rhs, pun_flag)
- = tcGlobalOcc field_label `thenNF_Tc` \ (sel_id, _, tau) ->
+ = tcLookupGlobalValue field_label `thenNF_Tc` \ sel_id ->
+ tcInstId sel_id `thenNF_Tc` \ (_, _, tau) ->
-- Record selectors all have type
-- forall a1..an. T a1 .. an -> tau
ppr sty expected_arg_ty])
badFieldsUpd rbinds sty
- = ppHang (ppStr "In a record update construct, no constructor has all these fields:")
+ = ppHang (ppStr "No constructor has all these fields:")
4 (interpp'SP sty fields)
where
fields = [field | (field, _, _) <- rbinds]
+recordUpdCtxt sty = ppStr "In a record update construct"
+
badFieldsCon con rbinds sty
= ppHang (ppBesides [ppStr "Inconsistent constructor:", ppr sty con])
4 (ppBesides [ppStr "and fields:", interpp'SP sty fields])
TypecheckedQual(..), TypecheckedStmt(..),
TypecheckedMatch(..), TypecheckedHsModule(..),
TypecheckedGRHSsAndBinds(..), TypecheckedGRHS(..),
+ TypecheckedRecordBinds(..),
mkHsTyApp, mkHsDictApp,
mkHsTyLam, mkHsDictLam,
type TypecheckedMatch = Match TyVar UVar Id TypecheckedPat
type TypecheckedGRHSsAndBinds = GRHSsAndBinds TyVar UVar Id TypecheckedPat
type TypecheckedGRHS = GRHS TyVar UVar Id TypecheckedPat
+type TypecheckedRecordBinds = HsRecordBinds TyVar UVar Id TypecheckedPat
type TypecheckedHsModule = HsModule TyVar UVar Id TypecheckedPat
\end{code}
import Id ( GenId, idType, isDefaultMethodId_maybe )
import ListSetOps ( minusList )
import Maybes ( maybeToBool, expectJust )
-import Outputable ( getLocalName, getOrigName )
+import Name ( getLocalName, getOrigName )
import PrelInfo ( pAT_ERROR_ID )
import PprType ( GenType, GenTyVar, GenClass, GenClassOp, TyCon,
pprParendGenType )
let tag = panic "processInstBinds1:getTagFromClassOpName"{-getTagFromClassOpName op-}
method_id = method_ids !! (tag-1)
- TcId method_bndr = method_id
- method_ty = idType method_bndr
+ method_ty = tcIdType method_id
(method_tyvars, method_theta, method_tau) = splitSigmaTy method_ty
in
newDicts origin method_theta `thenNF_Tc` \ (method_dicts,method_dict_ids) ->
import Id ( GenId, mkDictFunId, mkConstMethodId, mkSysLocal )
import MatchEnv ( nullMEnv, insertMEnv )
import Maybes ( MaybeErr(..), mkLookupFunDef )
-import Outputable ( getSrcLoc )
+import Name ( getSrcLoc )
import PprType ( GenClass, GenType, GenTyVar )
import Pretty
import SpecEnv ( SpecEnv(..), nullSpecEnv, addOneToSpecEnv )
import Class ( GenClass )
import Id ( GenId, isDataCon, isMethodSelId, idType )
import Maybes ( catMaybes )
-import Outputable ( isExported, isLocallyDefined )
+import Name ( isExported, isLocallyDefined )
import PrelInfo ( unitTy, mkPrimIoTy )
import Pretty
import RnUtils ( GlobalNameMappers(..), GlobalNameMapper(..) )
import Bag ( Bag, emptyBag, isEmptyBag,
foldBag, unitBag, unionBags, snocBag )
import FiniteMap ( FiniteMap, emptyFM )
-import Outputable ( Outputable(..), NamedThing(..), ExportFlag )
+--import Outputable ( Outputable(..), NamedThing(..), ExportFlag )
import ErrUtils ( Error(..) )
import Maybes ( MaybeErr(..) )
--import Name ( Name )
newMethod, newOverloadedLit
)
import TcEnv ( tcLookupGlobalValue, tcLookupGlobalValueByKey,
- tcLookupLocalValueOK, tcGlobalOcc )
-import TcType ( TcType(..), TcMaybe, tcInstType, newTyVarTy, newTyVarTys )
+ tcLookupLocalValueOK )
+import TcType ( TcType(..), TcMaybe, tcInstType, newTyVarTy, newTyVarTys, tcInstId )
import Unify ( unifyTauTy, unifyTauTyList, unifyTauTyLists )
import Bag ( Bag )
\begin{code}
tcPat pat_in@(RecPatIn name rpats)
- = tcGlobalOcc name `thenNF_Tc` \ (con_id, _, con_rho) ->
+ = tcLookupGlobalValue name `thenNF_Tc` \ con_id ->
+ tcInstId con_id `thenNF_Tc` \ (_, _, con_tau) ->
let
- (_, con_tau) = splitRhoTy con_rho
-- Ignore the con_theta; overloaded constructors only
-- behave differently when called, not when used for
-- matching.
where
do_bind expected_record_ty (field_label, rhs_pat, pun_flag)
- = tcGlobalOcc field_label `thenNF_Tc` \ (sel_id, _, tau) ->
+ = tcLookupGlobalValue field_label `thenNF_Tc` \ sel_id ->
+ tcInstId sel_id `thenNF_Tc` \ (_, _, tau) ->
-- Record selectors all have type
-- forall a1..an. T a1 .. an -> tau
matchConArgTys :: RnName -> [TcType s] -> TcM s (Id, TcType s)
matchConArgTys con arg_tys
- = tcGlobalOcc con `thenNF_Tc` \ (con_id, _, con_rho) ->
- let
- (con_theta, con_tau) = splitRhoTy con_rho
+ = tcLookupGlobalValue con `thenNF_Tc` \ con_id ->
+ tcInstId con_id `thenNF_Tc` \ (_, _, con_tau) ->
-- Ignore the con_theta; overloaded constructors only
-- behave differently when called, not when used for
-- matching.
-
+ let
(con_args, con_result) = splitFunTy con_tau
con_arity = length con_args
no_of_args = length arg_tys
isSuperClassOf, getSuperDictSelId )
import Id ( GenId )
import Maybes ( expectJust, firstJust, catMaybes, seqMaybe, maybeToBool, Maybe(..) )
-import Outputable ( Outputable(..) )
+import Outputable ( Outputable(..){-instance * []-} )
import PprType ( GenType, GenTyVar )
import Pretty
import SrcLoc ( mkUnknownSrcLoc )
tcExtendGlobalValEnv,
tcTyVarScope, tcGetEnv )
import TcKind ( TcKind, newKindVars )
-import TcTyDecls ( tcTyDecl, tcRecordSelectors )
+import TcTyDecls ( tcTyDecl, mkDataBinds )
import Bag
import Class ( Class(..), getClassSelIds )
import Digraph ( findSCCs, SCC(..) )
-import Outputable ( getSrcLoc )
+import Name ( getSrcLoc )
import PprStyle
import Pretty
import UniqSet ( UniqSet(..), emptyUniqSet,
unitUniqSet, unionUniqSets,
unionManyUniqSets, uniqSetToList )
import SrcLoc ( SrcLoc )
-import TyCon ( TyCon, tyConDataCons )
+import TyCon ( TyCon, tyConDataCons, isDataTyCon )
import Unique ( Unique )
import Util ( panic, pprTrace )
-- Create any necessary record selector Ids and their bindings
- mapAndUnzipTc tcRecordSelectors tycons `thenTc` \ (sel_ids_s, binds) ->
+ mapAndUnzipTc mkDataBinds (filter isDataTyCon tycons) `thenTc` \ (data_ids_s, binds) ->
-- Extend the global value environment with
-- a) constructors
-- c) class op selectors
tcSetEnv final_env $
- tcExtendGlobalValEnv (concat (map tyConDataCons tycons)) $
- tcExtendGlobalValEnv (concat sel_ids_s) $
+ tcExtendGlobalValEnv (concat data_ids_s) $
tcExtendGlobalValEnv (concat (map getClassSelIds classes)) $
tcGetEnv `thenNF_Tc` \ really_final_env ->
module TcTyDecls (
tcTyDecl,
tcConDecl,
- tcRecordSelectors
+ mkDataBinds
) where
import Ubiq{-uitous-}
import HsSyn ( TyDecl(..), ConDecl(..), BangType(..), HsExpr(..),
Match(..), GRHSsAndBinds(..), GRHS(..), OutPat(..),
- HsBinds(..), HsLit, Stmt, Qual, ArithSeqInfo, PolyType,
+ HsBinds(..), HsLit, Stmt, Qual, ArithSeqInfo,
+ PolyType, Fake, InPat,
Bind(..), MonoBinds(..), Sig,
MonoType )
import RnHsSyn ( RenamedTyDecl(..), RenamedConDecl(..),
RnName{-instance Outputable-}
)
-import TcHsSyn ( TcHsBinds(..), TcIdOcc(..), mkHsTyLam )
+import TcHsSyn ( mkHsTyLam, tcIdType, zonkId, TcHsBinds(..), TcIdOcc(..) )
+import Inst ( newDicts, InstOrigin(..), Inst )
import TcMonoType ( tcMonoTypeKind, tcMonoType, tcContext )
-import TcType ( tcInstTyVars, tcInstType )
+import TcType ( tcInstTyVars, tcInstType, tcInstId )
import TcEnv ( tcLookupTyCon, tcLookupTyVar, tcLookupClass,
- newLocalId
+ tcLookupClassByKey,
+ newLocalId, newLocalIds
)
import TcMonad
import TcKind ( TcKind, unifyKind, mkTcArrowKind, mkTcTypeKind )
+import Class ( GenClass{-instance Eq-} )
import Id ( mkDataCon, dataConSig, mkRecordSelId,
- dataConFieldLabels, StrictnessMark(..)
+ dataConFieldLabels, dataConStrictMarks,
+ StrictnessMark(..),
+ GenId{-instance NamedThing-}
)
import FieldLabel
import Kind ( Kind, mkArrowKind, mkBoxedTypeKind )
import SpecEnv ( SpecEnv(..), nullSpecEnv )
-import Name ( Name{-instance Ord3-} )
+import Name ( nameSrcLoc, isLocallyDefinedName, getSrcLoc,
+ Name{-instance Ord3-}
+ )
import Pretty
-import TyCon ( TyCon, NewOrData(..), mkSynTyCon, mkDataTyCon, tyConDataCons )
-import Type ( getTypeKind, getTyVar, tyVarsOfTypes, eqTy, applyTyCon,
- mkForAllTys, mkFunTy )
-import TyVar ( getTyVarKind, elementOfTyVarSet )
+import TyCon ( TyCon, NewOrData(..), mkSynTyCon, mkDataTyCon, isDataTyCon,
+ tyConDataCons )
+import Type ( getTypeKind, getTyVar, tyVarsOfTypes, eqTy,
+ applyTyCon, mkTyVarTys, mkForAllTys, mkFunTy,
+ splitFunTy, mkTyVarTy, getTyVar_maybe
+ )
+import TyVar ( getTyVarKind, elementOfTyVarSet, GenTyVar{-instance Eq-} )
+import Unique ( Unique {- instance Eq -}, dataClassKey )
import UniqSet ( emptyUniqSet, mkUniqSet, uniqSetToList, unionManyUniqSets, UniqSet(..) )
-import Util ( panic, equivClasses )
+import Util ( equivClasses, zipEqual, panic, assertPanic )
\end{code}
\begin{code}
returnNF_Tc clas
\end{code}
-Generating selector bindings for record delarations
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Generating constructor/selector bindings for data declarations
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
\begin{code}
-tcRecordSelectors :: TyCon -> TcM s ([Id], TcHsBinds s)
-tcRecordSelectors tycon
- = mapAndUnzipTc (tcRecordSelector tycon) groups `thenTc` \ (ids, binds) ->
- returnTc (ids, SingleBind (NonRecBind (foldr AndMonoBinds EmptyMonoBinds binds)))
+mkDataBinds :: TyCon -> TcM s ([Id], TcHsBinds s)
+mkDataBinds tycon
+ = ASSERT( isDataTyCon tycon )
+ mapAndUnzipTc mkConstructor data_cons `thenTc` \ (con_ids, con_binds) ->
+ mapAndUnzipTc (mkRecordSelector tycon) groups `thenTc` \ (sel_ids, sel_binds) ->
+ returnTc (con_ids ++ sel_ids,
+ SingleBind $ NonRecBind $
+ foldr AndMonoBinds
+ (foldr AndMonoBinds EmptyMonoBinds con_binds)
+ con_binds
+ )
where
data_cons = tyConDataCons tycon
fields = [ (con, field) | con <- data_cons,
= fieldLabelName field1 `cmp` fieldLabelName field2
\end{code}
+We're going to build a constructor that looks like:
+
+ data (Data a, C b) => T a b = T1 !a !Int b
+
+ T1 = /\ a b ->
+ \d1::Data a, d2::C b ->
+ \p q r -> case p of { p ->
+ case q of { q ->
+ HsCon [a,b,c] [p,q,r]}}
+
+Notice that
+
+* d2 is thrown away --- a context in a data decl is used to make sure
+ one *could* construct dictionaries at the site the constructor
+ is used, but the dictionary isn't actually used.
+
+* We have to check that we can construct Data dictionaries for
+ the types a and Int. Once we've done that we can throw d1 away too.
+
+* We use (case p of ...) to evaluate p, rather than "seq" because
+ all that matters is that the arguments are evaluated. "seq" is
+ very careful to preserve evaluation order, which we don't need
+ to be here.
+
+\begin{code}
+mkConstructor con_id
+ | not (isLocallyDefinedName (getName con_id))
+ = returnTc (con_id, EmptyMonoBinds)
+
+ | otherwise -- It is locally defined
+ = tcInstId con_id `thenNF_Tc` \ (tyvars, theta, tau) ->
+ newDicts DataDeclOrigin theta `thenNF_Tc` \ (_, dicts) ->
+ let
+ (arg_tys, result_ty) = splitFunTy tau
+ n_args = length arg_tys
+ in
+ newLocalIds (take n_args (repeat SLIT("con"))) arg_tys `thenNF_Tc` {- \ pre_zonk_args ->
+ mapNF_Tc zonkId pre_zonk_args `thenNF_Tc` -} \ args ->
+
+ -- Check that all the types of all the strict
+ -- arguments are in Data. This is trivially true of everything except
+ -- type variables, for which we must check the context.
+ let
+ strict_marks = dataConStrictMarks con_id
+ strict_args = [arg | (arg, MarkedStrict) <- args `zipEqual` strict_marks]
+
+ data_tyvars = -- The tyvars in the constructor's context that are arguments
+ -- to the Data class
+ [getTyVar "mkConstructor" ty
+ | (clas,ty) <- theta,
+ uniqueOf clas == dataClassKey]
+
+ check_data arg = case getTyVar_maybe (tcIdType arg) of
+ Nothing -> returnTc () -- Not a tyvar, so OK
+ Just tyvar -> checkTc (tyvar `elem` data_tyvars) (missingDataErr tyvar)
+ in
+ mapTc check_data strict_args `thenTc_`
+
+ -- Build the data constructor
+ let
+ con_rhs = mkHsTyLam tyvars $
+ DictLam dicts $
+ mk_pat_match args $
+ mk_case strict_args $
+ HsCon con_id arg_tys (map HsVar args)
+
+ mk_pat_match [] body = body
+ mk_pat_match (arg:args) body = HsLam (PatMatch (VarPat arg) (SimpleMatch (mk_pat_match args body)))
+
+ mk_case [] body = body
+ mk_case (arg:args) body = HsCase (HsVar arg)
+ [PatMatch (VarPat arg) (SimpleMatch (mk_case args body))]
+ src_loc
+
+ src_loc = nameSrcLoc (getName con_id)
+ in
+
+ returnTc (con_id, VarMonoBind (RealId con_id) con_rhs)
+\end{code}
+
We're going to build a record selector that looks like this:
data T a b c = T1 { op :: a, ...}
label; it has to be an Id, you see!
\begin{code}
-tcRecordSelector tycon fields@((first_con, first_field_label) : other_fields)
- = panic "tcRecordSelector: don't typecheck"
-{-
+mkRecordSelector tycon fields@((first_con, first_field_label) : other_fields)
= let
field_ty = fieldLabelType first_field_label
field_name = fieldLabelName first_field_label
- other_tys = [fieldLabelType fl | (_, fl) <- fields]
+ other_tys = [fieldLabelType fl | (_, fl) <- other_fields]
(tyvars, _, _, _) = dataConSig first_con
- -- tyvars of first_con may be free in first_ty
+ data_ty = applyTyCon tycon (mkTyVarTys tyvars)
+ -- tyvars of first_con may be free in field_ty
in
-- Check that all the fields in the group have the same type
tcInstTyVars tyvars `thenNF_Tc` \ (tyvars', tyvar_tys, tenv) ->
tcInstType tenv field_ty `thenNF_Tc` \ field_ty' ->
let
- data_ty' = applyTyCon tycon tyvar_tys
+ data_ty' = applyTyCon tycon tyvar_tys
in
newLocalId SLIT("x") field_ty' `thenNF_Tc` \ field_id ->
newLocalId SLIT("r") data_ty' `thenNF_Tc` \ record_id ->
-- Now build the selector
let
- tycon_src_loc = getSrcLoc tycon
-
- selector_ty = mkForAllTys tyvars' $
- mkFunTy data_ty' $
- field_ty'
+ selector_ty :: Type
+ selector_ty = mkForAllTys tyvars $
+ mkFunTy data_ty $
+ field_ty
+ selector_id :: Id
selector_id = mkRecordSelId first_field_label selector_ty
-- HsSyn is dreadfully verbose for defining the selector!
selector_rhs = mkHsTyLam tyvars' $
HsLam $
PatMatch (VarPat record_id) $
- GRHSMatch $
- GRHSsAndBindsOut [OtherwiseGRHS selector_body tycon_src_loc]
- EmptyBinds field_ty'
+ SimpleMatch $
+ selector_body
- selector_body = HsCase (HsVar record_id) (map mk_match fields) tycon_src_loc
+ selector_body = HsCase (HsVar record_id) (map mk_match fields) (getSrcLoc tycon)
mk_match (con_id, field_label)
- = PatMatch (RecPat con_id data_ty' [(selector_id, VarPat field_id, False)]) $
- GRHSMatch $
- GRHSsAndBindsOut [OtherwiseGRHS (HsVar field_id)
- (getSrcLoc (fieldLabelName field_label))]
- EmptyBinds
- field_ty'
+ = PatMatch (RecPat con_id data_ty' [(RealId selector_id, VarPat field_id, False)]) $
+ SimpleMatch $
+ HsVar field_id
in
- returnTc (selector_id, VarMonoBind selector_id selector_rhs)
--}
+ returnTc (selector_id, if isLocallyDefinedName (getName tycon)
+ then VarMonoBind (RealId selector_id) selector_rhs
+ else EmptyMonoBinds)
\end{code}
Constructors
fieldTypeMisMatch field_name sty
= ppSep [ppStr "Declared types differ for field", ppr sty field_name]
+
+missingDataErr tyvar sty
+ = ppStr "Missing `data' (???)" -- ToDo: improve
\end{code}
tcInstTyVars, -- TyVar -> NF_TcM s (TcTyVar s)
tcInstSigTyVars,
- tcInstType, tcInstTcType, tcInstTheta,
+ tcInstType, tcInstTcType, tcInstTheta, tcInstId,
zonkTcTyVars, -- TcTyVarSet s -> NF_TcM s (TcTyVarSet s)
zonkTcType, -- TcType s -> NF_TcM s (TcType s)
-- friends:
-import Type ( Type(..), ThetaType(..), GenType(..), tyVarsOfTypes, getTyVar_maybe )
+import Type ( Type(..), ThetaType(..), GenType(..),
+ tyVarsOfTypes, getTyVar_maybe,
+ splitForAllTy, splitRhoTy
+ )
import TyVar ( TyVar(..), GenTyVar(..), TyVarSet(..), GenTyVarSet(..),
tyVarSetToList
)
-- others:
-import Kind ( Kind )
-import Usage ( Usage(..), GenUsage, UVar(..), duffUsage )
import Class ( GenClass )
+import Id ( idType )
+import Kind ( Kind )
import TcKind ( TcKind )
import TcMonad
+import Usage ( Usage(..), GenUsage, UVar(..), duffUsage )
import Ubiq
import Unique ( Unique )
go (clas,ty) = tcInstType tenv ty `thenNF_Tc` \ tc_ty ->
returnNF_Tc (clas, tc_ty)
---???tcSpecTy :: Type -> NF_TcM s (
+-- A useful function that takes an occurrence of a global thing
+-- and instantiates its type with fresh type variables
+tcInstId :: Id
+ -> NF_TcM s ([TcTyVar s], -- It's instantiated type
+ TcThetaType s, --
+ TcType s) --
+
+tcInstId id
+ = let
+ (tyvars, rho) = splitForAllTy (idType id)
+ in
+ tcInstTyVars tyvars `thenNF_Tc` \ (tyvars', arg_tys, tenv) ->
+ tcInstType tenv rho `thenNF_Tc` \ rho' ->
+ let
+ (theta', tau') = splitRhoTy rho'
+ in
+ returnNF_Tc (tyvars', theta', tau')
+
tcInstTcType :: [(TcTyVar s,TcType s)] -> TcType s -> NF_TcM s (TcType s)
tcInstTcType tenv ty_to_inst
import Usage ( GenUsage, Usage(..), UVar(..) )
import Maybes ( assocMaybe, Maybe )
-import Name ( Name )
+--import Name ( Name )
import Unique -- Keys for built-in classes
-import Outputable ( Outputable(..), NamedThing(..), ExportFlag )
+--import Outputable ( Outputable(..), NamedThing(..), ExportFlag )
import Pretty ( Pretty(..), PrettyRep )
import PprStyle ( PprStyle )
import SrcLoc ( SrcLoc )
import Ubiq{-uitous-}
import Util ( panic )
-import Outputable ( Outputable(..) )
+--import Outputable ( Outputable(..) )
import Pretty
\end{code}
import CStrings ( identToC )
import CmdLineOpts ( opt_OmitInterfacePragmas )
import Maybes ( maybeToBool )
-import Name ( Name )
-import Outputable ( isAvarop, isPreludeDefined, getOrigName,
- ifPprShowAll, interpp'SP
+import Name ( isAvarop, isPreludeDefined, getOrigName,
+ Name{-instance Outputable-}
)
+import Outputable ( ifPprShowAll, interpp'SP )
import PprStyle ( PprStyle(..), codeStyle, showUserishTypes )
import Pretty
import TysWiredIn ( listTyCon )
import Maybes
import Name ( Name, RdrName(..), appendRdr, nameUnique )
import Unique ( Unique, funTyConKey, mkTupleTyConUnique )
-import Outputable
import Pretty ( Pretty(..), PrettyRep )
import PprStyle ( PprStyle )
import SrcLoc ( SrcLoc, mkBuiltinSrcLoc )
import FieldLabel ( FieldLabel )
import Id ( Id, GenId, StrictnessMark, mkTupleCon, mkDataCon,
- dataConSig, getInstantiatedDataConSig )
+ dataConSig, dataConArgTys )
import PprType ( specMaybeTysSuffix )
import Name ( Name )
import TyCon ( TyCon )
instance Eq (GenClass a b)
-- Needed in Type
-getInstantiatedDataConSig :: Id -> [Type] -> ([Type],[Type],Type)
+dataConArgTys :: Id -> [Type] -> [Type]
-- Needed in TysWiredIn
data StrictnessMark = MarkedStrict | NotMarkedStrict
import Name ( mkLocalName, Name, RdrName(..) )
import Pretty ( Pretty(..), PrettyRep, ppBeside, ppPStr )
import PprStyle ( PprStyle )
-import Outputable ( Outputable(..), NamedThing(..), ExportFlag(..) )
+--import Outputable ( Outputable(..), NamedThing(..), ExportFlag(..) )
import SrcLoc ( mkUnknownSrcLoc, SrcLoc )
import Unique ( showUnique, mkAlphaTyVarUnique, Unique )
import Util ( panic, Ord3(..) )
maybeBoxedPrimType ty
= case (maybeAppDataTyCon ty) of -- Data type,
Just (tycon, tys_applied, [data_con]) -- with exactly one constructor
- -> case (getInstantiatedDataConSig data_con tys_applied) of
- (_, [data_con_arg_ty], _) -- Applied to exactly one type,
+ -> case (dataConArgTys data_con tys_applied) of
+ [data_con_arg_ty] -- Applied to exactly one type,
| isPrimType data_con_arg_ty -- which is primitive
-> Just (data_con, data_con_arg_ty)
other_cases -> Nothing
#include "HsVersions.h"
module Outputable (
- -- NAMED-THING-ERY
- NamedThing(..), -- class
- ExportFlag(..),
-
- getItsUnique, getOrigName, getOccName, getExportFlag,
- getSrcLoc, isLocallyDefined, isPreludeDefined, isExported,
- getLocalName, getOrigNameRdr, ltLexical,
-
- -- PRINTERY AND FORCERY
Outputable(..), -- class
interppSP, interpp'SP,
ifnotPprForUser,
ifPprDebug,
ifPprShowAll, ifnotPprShowAll,
- ifPprInterface,
-
- isOpLexeme, pprOp, pprNonOp,
- isConop, isAconop, isAvarid, isAvarop
+ ifPprInterface
) where
import Ubiq{-uitous-}
-import Name ( nameUnique, nameOrigName, nameOccName,
- nameExportFlag, nameSrcLoc,
- isLocallyDefinedName, isPreludeDefinedName
- )
import PprStyle ( PprStyle(..) )
import Pretty
import Util ( cmpPString )
%************************************************************************
%* *
-\subsection[NamedThing-class]{The @NamedThing@ class}
-%* *
-%************************************************************************
-
-\begin{code}
-class NamedThing a where
- getName :: a -> Name
-
-getItsUnique :: NamedThing a => a -> Unique
-getOrigName :: NamedThing a => a -> (Module, FAST_STRING)
-getOccName :: NamedThing a => a -> RdrName
-getExportFlag :: NamedThing a => a -> ExportFlag
-getSrcLoc :: NamedThing a => a -> SrcLoc
-isLocallyDefined :: NamedThing a => a -> Bool
-isPreludeDefined :: NamedThing a => a -> Bool
-
-getItsUnique = nameUnique . getName
-getOrigName = nameOrigName . getName
-getOccName = nameOccName . getName
-getExportFlag = nameExportFlag . getName
-getSrcLoc = nameSrcLoc . getName
-isLocallyDefined = isLocallyDefinedName . getName
-isPreludeDefined = isPreludeDefinedName . getName
-
-isExported a
- = case (getExportFlag a) of
- NotExported -> False
- _ -> True
-
-getLocalName :: (NamedThing a) => a -> FAST_STRING
-getLocalName = snd . getOrigName
-
-getOrigNameRdr :: (NamedThing a) => a -> RdrName
-getOrigNameRdr n | isPreludeDefined n = Unqual str
- | otherwise = Qual mod str
- where
- (mod,str) = getOrigName n
-
-#ifdef USE_ATTACK_PRAGMAS
-{-# SPECIALIZE isExported :: Class -> Bool #-}
-{-# SPECIALIZE isExported :: Id -> Bool #-}
-{-# SPECIALIZE isExported :: TyCon -> Bool #-}
-#endif
-\end{code}
-
-@ltLexical@ is used for sorting things into lexicographical order, so
-as to canonicalize interfaces. [Regular @(<)@ should be used for fast
-comparison.]
-
-\begin{code}
-a `ltLexical` b
- = BIND isLocallyDefined a _TO_ a_local ->
- BIND isLocallyDefined b _TO_ b_local ->
- BIND getOrigName a _TO_ (a_mod, a_name) ->
- BIND getOrigName b _TO_ (b_mod, b_name) ->
- if a_local || b_local then
- a_name < b_name -- can't compare module names
- else
- case _CMP_STRING_ a_mod b_mod of
- LT_ -> True
- EQ_ -> a_name < b_name
- GT__ -> False
- BEND BEND BEND BEND
-
-#ifdef USE_ATTACK_PRAGMAS
-{-# SPECIALIZE ltLexical :: Class -> Class -> Bool #-}
-{-# SPECIALIZE ltLexical :: Id -> Id -> Bool #-}
-{-# SPECIALIZE ltLexical :: TyCon -> TyCon -> Bool #-}
-#endif
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[ExportFlag-datatype]{The @ExportFlag@ datatype}
-%* *
-%************************************************************************
-
-The export flag @ExportAll@ means `export all there is', so there are
-times when it is attached to a class or data type which has no
-ops/constructors (if the class/type was imported abstractly). In
-fact, @ExportAll@ is attached to everything except to classes/types
-which are being {\em exported} abstractly, regardless of how they were
-imported.
-
-\begin{code}
-data ExportFlag
- = ExportAll -- export with all constructors/methods
- | ExportAbs -- export abstractly
- | NotExported
-\end{code}
-
-%************************************************************************
-%* *
\subsection[Outputable-class]{The @Outputable@ class}
%* *
%************************************************************************
ifnotPprShowAll sty p = case sty of PprShowAll -> ppNil ; _ -> p
\end{code}
-These functions test strings to see if they fit the lexical categories
-defined in the Haskell report.
-Normally applied as in e.g. @isConop (getLocalName foo)@
-
-\begin{code}
-isConop, isAconop, isAvarid, isAvarop :: FAST_STRING -> Bool
-
-isConop cs
- | _NULL_ cs = False
- | c == '_' = isConop (_TAIL_ cs) -- allow for leading _'s
- | otherwise = isUpper c || c == ':'
- || c == '[' || c == '(' -- [] () and (,,) come is as Conop strings !!!
- || isUpperISO c
- where
- c = _HEAD_ cs
-
-isAconop cs
- | _NULL_ cs = False
- | otherwise = c == ':'
- where
- c = _HEAD_ cs
-
-isAvarid cs
- | _NULL_ cs = False
- | c == '_' = isAvarid (_TAIL_ cs) -- allow for leading _'s
- | isLower c = True
- | isLowerISO c = True
- | otherwise = False
- where
- c = _HEAD_ cs
-
-isAvarop cs
- | _NULL_ cs = False
- | isLower c = False
- | isUpper c = False
- | c `elem` "!#$%&*+./<=>?@\\^|~-" = True
- | isSymbolISO c = True
- | otherwise = False
- where
- c = _HEAD_ cs
-
-isSymbolISO c = ord c `elem` (0xd7 : 0xf7 : [0xa1 .. 0xbf])
-isUpperISO c = 0xc0 <= oc && oc <= 0xde && oc /= 0xd7 where oc = ord c
-isLowerISO c = 0xdf <= oc && oc <= 0xff && oc /= 0xf7 where oc = ord c
-\end{code}
-
-And one ``higher-level'' interface to those:
-
-\begin{code}
-isOpLexeme :: NamedThing a => a -> Bool
-
-isOpLexeme v
- = let str = snd (getOrigName v) in isAvarop str || isAconop str
-
--- print `vars`, (op) correctly
-pprOp, pprNonOp :: (NamedThing name, Outputable name) => PprStyle -> name -> Pretty
-
-pprOp sty var
- = if isOpLexeme var
- then ppr sty var
- else ppBesides [ppChar '`', ppr sty var, ppChar '`']
-
-pprNonOp sty var
- = if isOpLexeme var
- then ppBesides [ppLparen, ppr sty var, ppRparen]
- else ppr sty var
-
-#ifdef USE_ATTACK_PRAGMAS
-{-# SPECIALIZE isOpLexeme :: Id -> Bool #-}
-{-# SPECIALIZE pprNonOp :: PprStyle -> Id -> Pretty #-}
-{-# SPECIALIZE pprNonOp :: PprStyle -> TyCon -> Pretty #-}
-{-# SPECIALIZE pprOp :: PprStyle -> Id -> Pretty #-}
-#endif
-\end{code}
-
\begin{code}
instance Outputable Bool where
ppr sty True = ppPStr SLIT("True")
import Literal ( Literal )
import Maybes ( MaybeErr )
import MatchEnv ( MatchEnv )
-import Name ( Module(..), RdrName, Name )
-import Outputable ( ExportFlag, NamedThing(..), Outputable(..) )
+import Name ( Module(..), RdrName, Name, ExportFlag, NamedThing(..) )
+import Outputable ( Outputable(..) )
import PprStyle ( PprStyle )
import PragmaInfo ( PragmaInfo )
import Pretty ( PrettyRep )
import TyCon ( TyCon, Arity(..) )
import TyVar ( GenTyVar, TyVar(..) )
import Type ( GenType, Type(..) )
-import UniqFM ( UniqFM )
+import UniqFM ( UniqFM, Uniquable(..) )
import UniqSupply ( UniqSupply )
-import Unique ( Unique, Uniquable(..) )
+import Unique ( Unique )
import Usage ( GenUsage, Usage(..) )
import Util ( Ord3(..) )
module UniqFM (
UniqFM, -- abstract type
+ Uniquable(..), -- class to go with it
emptyUFM,
unitUFM,
) where
#if defined(COMPILING_GHC)
-CHK_Ubiq() -- debugging consistency check
+import Ubiq{-uitous-}
#endif
-import Unique ( Unique, Uniquable(..), u2i, mkUniqueGrimily )
+import Unique ( Unique, u2i, mkUniqueGrimily )
import Util
-import Outputable ( Outputable(..), ExportFlag )
+--import Outputable ( Outputable(..), ExportFlag )
import Pretty ( Pretty(..), PrettyRep )
import PprStyle ( PprStyle )
import SrcLoc ( SrcLoc )
(UniqFM ele)
(UniqFM ele)
+class Uniquable a where
+ uniqueOf :: a -> Unique
+
-- for debugging only :-)
{-
instance Text (UniqFM a) where
isEmptyUniqSet
) where
-CHK_Ubiq() -- debugging consistency check
+import Ubiq{-uitous-}
import Maybes ( maybeToBool, Maybe )
import UniqFM
-import Unique ( Uniquable(..), Unique )
-import Outputable ( Outputable(..), ExportFlag )
+import Unique ( Unique )
+--import Outputable ( Outputable(..), ExportFlag )
import SrcLoc ( SrcLoc )
import Pretty ( Pretty(..), PrettyRep )
import PprStyle ( PprStyle )
%* *
%************************************************************************
-We use @UniqFM@, with a (@getItsUnique@-able) @Unique@ as ``key''
+We use @UniqFM@, with a (@uniqueOf@-able) @Unique@ as ``key''
and the thing itself as the ``value'' (for later retrieval).
\begin{code}
projects / ghc-hetmet.git / commitdiff