import {-# SOURCE #-} Match ( matchSimply )
import HsSyn
-import TcHsSyn ( TypecheckedPat )
-import DsHsSyn ( outPatType, collectTypedPatBinders )
+import TcHsSyn ( TypecheckedPat, outPatType, collectTypedPatBinders )
import CoreSyn
import DsMonad
import MkId ( rebuildConArgs )
import Id ( idType, Id, mkWildId )
import Literal ( Literal(..), inIntRange, tARGET_MAX_INT )
-import TyCon ( isNewTyCon, tyConDataCons )
-import DataCon ( DataCon, dataConStrictMarks, dataConId )
-import Type ( mkFunTy, isUnLiftedType, splitAlgTyConApp,
- Type
- )
+import TyCon ( isNewTyCon, tyConDataCons, isRecursiveTyCon )
+import DataCon ( DataCon, dataConStrictMarks, dataConId,
+ dataConSourceArity )
+import Type ( mkFunTy, isUnLiftedType, Type, splitTyConApp )
+import TcType ( tcTyConAppTyCon, isIntTy, isFloatTy, isDoubleTy )
import TysPrim ( intPrimTy, charPrimTy, floatPrimTy, doublePrimTy )
import TysWiredIn ( nilDataCon, consDataCon,
tupleCon,
- stringTy,
unitDataConId, unitTy,
charTy, charDataCon,
intTy, intDataCon, smallIntegerDataCon,
- floatTy, floatDataCon,
- doubleTy, doubleDataCon,
- stringTy
- )
+ floatDataCon,
+ doubleDataCon,
+ stringTy, isPArrFakeCon )
import BasicTypes ( Boxity(..) )
import UniqSet ( mkUniqSet, minusUniqSet, isEmptyUniqSet, UniqSet )
import PrelNames ( unpackCStringName, unpackCStringUtf8Name,
- plusIntegerName, timesIntegerName )
+ plusIntegerName, timesIntegerName,
+ lengthPName, indexPName )
import Outputable
import UnicodeUtil ( stringToUtf8 )
+import Util ( isSingleton )
\end{code}
mk_char_lit c = ConPat charDataCon charTy [] [] [LitPat (HsCharPrim c) charPrimTy]
tidyNPat lit lit_ty default_pat
- | lit_ty == intTy = ConPat intDataCon lit_ty [] [] [LitPat (mk_int lit) intPrimTy]
- | lit_ty == floatTy = ConPat floatDataCon lit_ty [] [] [LitPat (mk_float lit) floatPrimTy]
- | lit_ty == doubleTy = ConPat doubleDataCon lit_ty [] [] [LitPat (mk_double lit) doublePrimTy]
+ | isIntTy lit_ty = ConPat intDataCon lit_ty [] [] [LitPat (mk_int lit) intPrimTy]
+ | isFloatTy lit_ty = ConPat floatDataCon lit_ty [] [] [LitPat (mk_float lit) floatPrimTy]
+ | isDoubleTy lit_ty = ConPat doubleDataCon lit_ty [] [] [LitPat (mk_double lit) doublePrimTy]
| otherwise = default_pat
where
where
mk_case fail
= mapDs (mk_alt fail) match_alts `thenDs` \ alts ->
- returnDs (Case (Var var) var (alts ++ [(DEFAULT, [], fail)]))
+ returnDs (Case (Var var) var ((DEFAULT, [], fail) : alts))
mk_alt fail (lit, MatchResult _ body_fn) = body_fn fail `thenDs` \ body ->
returnDs (LitAlt lit, [], body)
mkCoAlgCaseMatchResult var match_alts
| isNewTyCon tycon -- Newtype case; use a let
- = ASSERT( newtype_sanity )
- mkCoLetsMatchResult [coercion_bind] match_result
+ = ASSERT( null (tail match_alts) && null (tail arg_ids) )
+ mkCoLetsMatchResult [NonRec arg_id newtype_rhs] match_result
+
+ | isPArrFakeAlts match_alts -- Sugared parallel array; use a literal case
+ = MatchResult CanFail mk_parrCase
| otherwise -- Datatype case; use a case
= MatchResult fail_flag mk_case
where
-- Common stuff
scrut_ty = idType var
- (tycon, _, _) = splitAlgTyConApp scrut_ty
+ tycon = tcTyConAppTyCon scrut_ty -- Newtypes must be opaque here
-- Stuff for newtype
(_, arg_ids, match_result) = head match_alts
- arg_id = head arg_ids
- coercion_bind = NonRec arg_id (Note (Coerce (idType arg_id)
- scrut_ty)
- (Var var))
- newtype_sanity = null (tail match_alts) && null (tail arg_ids)
+ arg_id = head arg_ids
+ newtype_rhs | isRecursiveTyCon tycon -- Recursive case; need a case
+ = Note (Coerce (idType arg_id) scrut_ty) (Var var)
+ | otherwise -- Normal case (newtype is transparent)
+ = Var var
+
-- Stuff for data types
data_cons = tyConDataCons tycon
wild_var = mkWildId (idType var)
mk_case fail = mapDs (mk_alt fail) match_alts `thenDs` \ alts ->
- returnDs (Case (Var var) wild_var (alts ++ mk_default fail))
+ returnDs (Case (Var var) wild_var (mk_default fail ++ alts))
mk_alt fail (con, args, MatchResult _ body_fn)
= body_fn fail `thenDs` \ body ->
un_mentioned_constructors
= mkUniqSet data_cons `minusUniqSet` mkUniqSet [ con | (con, _, _) <- match_alts]
exhaustive_case = isEmptyUniqSet un_mentioned_constructors
+
+ -- Stuff for parallel arrays
+ --
+ -- * the following is to desugar cases over fake constructors for
+ -- parallel arrays, which are introduced by `tidy1' in the `PArrPat'
+ -- case
+ --
+ -- Concerning `isPArrFakeAlts':
+ --
+ -- * it is *not* sufficient to just check the type of the type
+ -- constructor, as we have to be careful not to confuse the real
+ -- representation of parallel arrays with the fake constructors;
+ -- moreover, a list of alternatives must not mix fake and real
+ -- constructors (this is checked earlier on)
+ --
+ -- FIXME: We actually go through the whole list and make sure that
+ -- either all or none of the constructors are fake parallel
+ -- array constructors. This is to spot equations that mix fake
+ -- constructors with the real representation defined in
+ -- `PrelPArr'. It would be nicer to spot this situation
+ -- earlier and raise a proper error message, but it can really
+ -- only happen in `PrelPArr' anyway.
+ --
+ isPArrFakeAlts [(dcon, _, _)] = isPArrFakeCon dcon
+ isPArrFakeAlts ((dcon, _, _):alts) =
+ case (isPArrFakeCon dcon, isPArrFakeAlts alts) of
+ (True , True ) -> True
+ (False, False) -> False
+ _ ->
+ panic "DsUtils: You may not mix `[:...:]' with `PArr' patterns"
+ --
+ mk_parrCase fail =
+ dsLookupGlobalValue lengthPName `thenDs` \lengthP ->
+ unboxAlt `thenDs` \alt ->
+ returnDs (Case (len lengthP) (mkWildId intTy) [alt])
+ where
+ elemTy = case splitTyConApp (idType var) of
+ (_, [elemTy]) -> elemTy
+ _ -> panic panicMsg
+ panicMsg = "DsUtils.mkCoAlgCaseMatchResult: not a parallel array?"
+ len lengthP = mkApps (Var lengthP) [Type elemTy, Var var]
+ --
+ unboxAlt =
+ newSysLocalDs intPrimTy `thenDs` \l ->
+ dsLookupGlobalValue indexPName `thenDs` \indexP ->
+ mapDs (mkAlt indexP) match_alts `thenDs` \alts ->
+ returnDs (DataAlt intDataCon, [l], (Case (Var l) wild (dft : alts)))
+ where
+ wild = mkWildId intPrimTy
+ dft = (DEFAULT, [], fail)
+ --
+ -- each alternative matches one array length (corresponding to one
+ -- fake array constructor), so the match is on a literal; each
+ -- alternative's body is extended by a local binding for each
+ -- constructor argument, which are bound to array elements starting
+ -- with the first
+ --
+ mkAlt indexP (con, args, MatchResult _ bodyFun) =
+ bodyFun fail `thenDs` \body ->
+ returnDs (LitAlt lit, [], mkDsLets binds body)
+ where
+ lit = MachInt $ toInteger (dataConSourceArity con)
+ binds = [NonRec arg (indexExpr i) | (i, arg) <- zip [1..] args]
+ --
+ indexExpr i = mkApps (Var indexP) [Type elemTy, Var var, toInt i]
+ toInt i = mkConApp intDataCon [Lit $ MachInt i]
\end{code}
= returnDs [(v, val_expr)]
mkSelectorBinds pat val_expr
- | length binders == 1 || is_simple_pat pat
+ | isSingleton binders || is_simple_pat pat
= newSysLocalDs (exprType val_expr) `thenDs` \ val_var ->
-- For the error message we don't use mkErrorAppDs to avoid
| otherwise
- = mkErrorAppDs iRREFUT_PAT_ERROR_ID tuple_ty (showSDoc (ppr pat))
- `thenDs` \ error_expr ->
- matchSimply val_expr PatBindRhs pat local_tuple error_expr
- `thenDs` \ tuple_expr ->
- newSysLocalDs tuple_ty
- `thenDs` \ tuple_var ->
+ = mkErrorAppDs iRREFUT_PAT_ERROR_ID
+ tuple_ty (showSDoc (ppr pat)) `thenDs` \ error_expr ->
+ matchSimply val_expr PatBindRhs pat local_tuple error_expr `thenDs` \ tuple_expr ->
+ newSysLocalDs tuple_ty `thenDs` \ tuple_var ->
let
- mk_tup_bind binder =
- (binder, mkTupleSelector binders binder tuple_var (Var tuple_var))
+ mk_tup_bind binder
+ = (binder, mkTupleSelector binders binder tuple_var (Var tuple_var))
in
returnDs ( (tuple_var, tuple_expr) : map mk_tup_bind binders )
where
\end{code}
-
projects / ghc-hetmet.git / blobdiff