uhc-light-1.1.9.3: src/UHC/Light/Compiler/AbstractCore/Utils.hs
module UHC.Light.Compiler.AbstractCore.Utils
( RCEEnv' (..), emptyRCEEnv
, rceEnvDataAlts
, acorePatTagArityMbNms
, acoreAltLSaturate
, acoreAltOffsetL
, MbPatRest'
, acoreStrictSatCaseTy
, acoreSelsCaseTy
, acoreSelCaseTy
, acoreSatSelsCasesTy
, acoreSatSelsCaseTy
, acoreExprSatSelCaseTy
, rceMatchTy
, rceUpdEnv
, acoreRPatBindL2BindL
, acoreCSubstFromVarMpImpls
, acoreMatchStringTy
, acoreMatchTupleTy )
where
import UHC.Light.Compiler.AbstractCore
import UHC.Light.Compiler.Base.HsName.Builtin
import UHC.Light.Compiler.Base.Common
import UHC.Light.Compiler.Opts
import UHC.Light.Compiler.Ty
import UHC.Light.Compiler.Gam
import UHC.Light.Compiler.Gam.ValGam
import UHC.Light.Compiler.Gam.DataGam
import UHC.Light.Compiler.VarMp
import UHC.Light.Compiler.Substitutable
import Data.List
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.Maybe
import UHC.Util.Utils
{-# LINE 32 "src/ehc/AbstractCore/Utils.chs" #-}
-- | Env to support Reordering of Case Expression (RCE)
data RCEEnv' expr bind bindasp ty
= RCEEnv
{ rceValGam :: !ValGam -- type of value (amongst other)
, rceTyVarMp :: !VarMp -- tvar bindings for ValGam
, rceDataGam :: !DataGam -- data type + constructor info
, rceCaseFailSubst :: !(CSubst' expr bind bindasp ty) -- fail continuation map
, rceCaseIds :: !UIDS -- fail ids
, rceCaseCont :: !expr -- continuation
, rceEHCOpts :: !EHCOpts -- options
-- , rceIsStrict :: !Bool -- scrutinee must be evaluated
}
emptyRCEEnv :: (AbstractCore e b bound boundmeta bcat t p pr pf a) => EHCOpts -> RCEEnv' e b ba t
emptyRCEEnv opts = RCEEnv emptyGam emptyVarMp emptyGam Map.empty (Set.singleton uidStart) (acoreBuiltinUndefined opts) opts -- True
{-# LINE 50 "src/ehc/AbstractCore/Utils.chs" #-}
-- | All tags of the type of the constructor for a tag t
rceEnvDataAlts :: RCEEnv' e b ba t -> CTag -> Maybe [CTag]
rceEnvDataAlts env t
= case t of
CTag _ conNm _ _ _
-> case valGamTyOfDataCon conNm (rceValGam env) of
(_,ty,[])
-> dataGamTagsOfTy (rceTyVarMp env `varUpd` ty) (rceDataGam env)
_ -> Nothing
-- panic ("rceEnvDataAlts: " ++ show conNm) -- Nothing
-- dataGamTagsOfTy (appCon conNm) (rceDataGam env)
_ -> Nothing
{-# LINE 69 "src/ehc/AbstractCore/Utils.chs" #-}
acorePatTagArityMbNms :: (AbstractCore e b bound boundmeta bcat t p pr pf a) => EHCOpts -> CTag -> Int -> Maybe [HsName] -> p
acorePatTagArityMbNms opts ctag arity mbNmL
= pat
where pat = acorePatCon ctag (acorePatRestEmpty) (zipWith mkB nmL [0 .. arity - 1])
mkB n o = acorePatFldTy (acoreTyErr "acorePatTagArityMbNms") (n,acoreInt opts o) n
nmL = maybe (repeat hsnWild) id mbNmL
{-# LINE 89 "src/ehc/AbstractCore/Utils.chs" #-}
acoreAltLSaturate :: (AbstractCore e b bound boundmeta bcat t p pr pf a) => RCEEnv' e b ba t -> [a] -> [a]
acoreAltLSaturate env alts
= case alts of
(alt1:_) -> listSaturateWith 0 (length allAlts - 1) altIntTag allAlts alts
where (allAlts,altIntTag)
= case acorePatMbCon pat of
-- if a con pat, use the tag to dispatch upon
Just (CTagRec,_,_)
-> ([(0,alt1)], const 0)
Just (tg,_,_)
-> case rceEnvDataAlts env tg of
Just ts -> ([ (ctagTag t,mkA env t (ctagArity t)) | t <- ts ], ctagTag . panicJust "acoreAltLSaturate.rceEnvDataAlts(2)" . acoreAltMbTag)
_ -> -- tr "acoreAltLSaturate" (pp tg) $
([(0,alt1)], const 0)
-- _ -> panic ("acoreAltLSaturate.rceEnvDataAlts(1): " ++ show tg)
_ -> case acorePatMbInt pat of
-- if an int, use the int to dispatch upon; used internally only (by deriving Enum)
Just (_,i) -> ([ (fromInteger i, a) | a <- alts ], fromInteger . snd . panicJust "acoreAltLSaturate.acorePatMbInt(2)" . acorePatMbInt . fst . acoreUnAlt)
_ -> panic "acoreAltLSaturate.acorePatMbInt(1)"
where (pat,_) = acoreUnAlt alt1
mkA env ct a = acoreAlt (acorePatTagArityMbNms (rceEHCOpts env) ct a Nothing) (rceCaseCont env)
_ -> []
{-# LINE 118 "src/ehc/AbstractCore/Utils.chs" #-}
acorePatBindOffsetL :: (AbstractCore e b bound boundmeta bcat t p pr pf a) => EHCOpts -> [pf] -> ([pf],[b])
acorePatBindOffsetL opts pbL
= let (pbL',obL)
= unzip
. map
(\b -> let ((l,o),pbind) = acoreUnPatFld b
(n,_) = acoreUnBind pbind
offNm = hsnUniqify HsNameUniqifier_FieldOffset l
in case acoreExprMbInt o of
Just _ -> (b,[])
_ -> (acorePatFldTy (acoreTyErr "acorePatBindOffsetL") (l,acoreVar offNm) n,[acoreBind1Ty offNm (acoreTyInt opts) o])
)
$ pbL
in (pbL',concat obL)
{-# LINE 135 "src/ehc/AbstractCore/Utils.chs" #-}
acoreAltOffsetL :: (AbstractCore e b bound boundmeta bcat t p pr pf a) => EHCOpts -> a -> (a,[b])
acoreAltOffsetL opts alt
= case acorePatMbCon p of
Just (t,r,b)
-> (acoreAlt (acorePatCon t r b') e,offBL)
where (b',offBL) = acorePatBindOffsetL opts b
_ -> (alt,[])
where (p,e) = acoreUnAlt alt
{-# LINE 150 "src/ehc/AbstractCore/Utils.chs" #-}
type MbPatRest' pr = Maybe (pr,Int) -- (pat rest, arity)
{-# LINE 154 "src/ehc/AbstractCore/Utils.chs" #-}
-- | Make case expression from alternatives, saturating the alternatives w.r.t. all constructors
-- | Either:
-- | - make a case expr from alternatives,
-- | saturating the alternatives with defaults for missing alternatives.
-- | - or, when only a single alternative binding a single field, bind it directly with a let
acoreStrictSatCaseTy :: (Eq bcat, AbstractCore e b bound boundmeta bcat t p pr pf a) => RCEEnv' e b ba t -> Maybe (HsName,t) -> e -> [a] -> e
acoreStrictSatCaseTy env mbNm e []
= rceCaseCont env -- TBD: should be error message "scrutinizing datatype without constructors"
acoreStrictSatCaseTy env mbNm e [alt]
| isJust mbPatCon && length flds == 1 && not (ctagIsRec tg) && isJust mbDgi && dgiIsNewtype (fromJust mbDgi)
= acoreLet cat
( [ acoreBind1CatTy cat pnm ty e ]
++ maybe [] (\(n,ty) -> [ acoreBind1CatTy cat n ty e ]) mbNm
) ae
where mbDgi = dataGamLookup (ctagTyNm tg) (rceDataGam env)
(pat,ae) = acoreUnAlt alt
mbPatCon@(~(Just (tg,_,flds@(~([fld]))))) = acorePatMbCon pat
(_,pbind) = acoreUnPatFld fld
(pnm,_) = acoreUnBind pbind
cat = acoreBindcategPlain
ty = maybe (acoreTyErr "acoreStrictSatCaseTy.ty") snd mbNm
acoreStrictSatCaseTy env mbNm e alts
= case mbNm of
Just (n,ty) -> acoreLet1StrictInTy n ty e $ mk alts
Nothing -> mk alts e
where mk (alt:alts) n
= acoreLet (acoreBindcategStrict) altOffBL (acoreCaseDflt n (acoreAltLSaturate env (alt':alts)) (Just undef))
where (alt',altOffBL) = acoreAltOffsetL (rceEHCOpts env) alt
mk [] n
= acoreCaseDflt n [] (Just undef) -- dummy case
undef = acoreBuiltinUndefined (rceEHCOpts env)
acoreStrictSatCase :: (Eq bcat, AbstractCore e b bound boundmeta bcat t p pr pf a) => RCEEnv' e b ba t -> Maybe (HsName) -> e -> [a] -> e
acoreStrictSatCase env eNm e alts = acoreStrictSatCaseTy env (acoreTyErrLift "acoreStrictSatCase" eNm) e alts
{-# INLINE acoreStrictSatCase #-}
{-# LINE 194 "src/ehc/AbstractCore/Utils.chs" #-}
-- | Make a case expr from non-saturated alternatives,
-- | alternatives are given by their tag + fields (name/offset) + rest (for extensible records) + alt expr
acoreSelsCasesTy :: (Eq bcat, AbstractCore e b bound boundmeta bcat t p pr pf a) => RCEEnv' e b ba t -> Maybe (HsName,t) -> e -> [(CTag,[(HsName,t,{-HsName,-}e)],MbPatRest' pr,e)] -> e
acoreSelsCasesTy env mbNm e tgSels
= acoreStrictSatCaseTy env mbNm e alts
where alts = [ acoreAlt
(acorePatCon ct
(mkRest mbRest ct)
[acorePatFldTy t (n,off) n | (n,t,{-lbl,-}off) <- nmLblOffL]
)
sel
| (ct,nmLblOffL,mbRest,sel) <- tgSels
]
mkRest mbr ct
= case mbr of
Just (r,_) -> r
_ -> ctag (acorePatRestVar hsnWild) (\_ _ _ _ _ -> acorePatRestEmpty) ct
{-# LINE 215 "src/ehc/AbstractCore/Utils.chs" #-}
-- | Make a case expr from a single alternative,
-- | the alternative given by their tag + fields (name/offset) + rest (for extensible records) + alt expr
acoreSelsCaseTy :: (Eq bcat, AbstractCore e b bound boundmeta bcat t p pr pf a) => RCEEnv' e b ba t -> Maybe (HsName,t) -> e -> CTag -> [(HsName,t,{-HsName,-}e)] -> MbPatRest' pr -> e -> e
acoreSelsCaseTy env ne e ct nmLblOffL mbRest sel = acoreSelsCasesTy env ne e [(ct,nmLblOffL,mbRest,sel)]
{-# INLINE acoreSelsCaseTy #-}
{-# LINE 223 "src/ehc/AbstractCore/Utils.chs" #-}
-- | Make a case expr from a single alternative with a single field,
-- | the alternative given by their tag + field (name/offset) + rest (for extensible records) + alt expr
acoreSelCaseTy :: (Eq bcat, AbstractCore e b bound boundmeta bcat t p pr pf a) => RCEEnv' e b ba t -> Maybe (HsName,t) -> e -> CTag -> HsName -> e -> MbPatRest' pr -> e
acoreSelCaseTy env ne e ct n {-lbl-} off mbRest
= acoreSelsCaseTy env ne e ct [(n,acoreTyErr $ "acoreSelCaseTy: " ++ show n,{-lbl,-}off)] mbRest (acoreVar n)
acoreSelCase :: (Eq bcat, AbstractCore e b bound boundmeta bcat t p pr pf a) => RCEEnv' e b ba t -> Maybe HsName -> e -> CTag -> HsName -> e -> MbPatRest' pr -> e
acoreSelCase env ne e ct n {-lbl-} off mbRest
= acoreSelCaseTy env (acoreTyErrLift "acoreSelCase" ne) e ct n {-lbl-} off mbRest
{-# INLINE acoreSelCase #-}
{-# LINE 236 "src/ehc/AbstractCore/Utils.chs" #-}
-- | Make a case expr from a single alternative with non-saturated fields,
-- | the alternative given by their tag + field (name/offset) + rest (for extensible records) + alt expr,
-- | the fields (and alternatives) are saturated according to the tag + rest info
acoreSatSelsCasesTy
:: forall e m b bound boundmeta bcat mbind t p pr pf a ba .
(Eq bcat, AbstractCore e b bound boundmeta bcat t p pr pf a) => RCEEnv' e b ba t -> Maybe (HsName,t) -> e -> [(CTag,[(HsName,t,{-HsName,-}Int)],MbPatRest' pr,e)] -> e
acoreSatSelsCasesTy env ne e tgSels
= acoreSelsCasesTy env ne e alts
where mkOffL ct mbr nol
= case (ct,mbr) of
(CTagRec ,Nothing ) -> map mklo nol
(CTagRec ,Just (_,a)) -> mkloL a
(CTag _ _ _ a _,_ ) -> mkloL a
where mklo :: (HsName,t,Int) -> (HsName,t,e)
mklo (n,t,o) = (n,t,acoreInt opts o)
mkloL :: Int -> [(HsName,t,e)]
mkloL a = map mklo
$ listSaturateWith
0 (a-1)
(\(_,_,o) -> o)
[(o,(l,acoreTyErr $ "acoreSatSelsCasesTy.mkloL: " ++ show l,o)) | (o,l) <- zip [0..a-1] hsnLclSupply]
nol
alts = [ (ct,mkOffL ct mbRest nmLblOffL,mbRest,sel) | (ct,nmLblOffL,mbRest,sel) <- tgSels ]
opts = rceEHCOpts env
{-# LINE 263 "src/ehc/AbstractCore/Utils.chs" #-}
-- | Make a case expr from a single alternative with non-saturated fields,
-- | the alternative given by their tag + field (name/offset) + rest (for extensible records) + alt expr,
-- | the fields (and alternatives) are saturated according to the tag + rest info
acoreSatSelsCaseTy :: (Eq bcat, AbstractCore e b bound boundmeta bcat t p pr pf a) => RCEEnv' e b ba t -> Maybe (HsName,t) -> e -> CTag -> [(HsName,t,{-HsName,-}Int)] -> MbPatRest' pr -> e -> e
acoreSatSelsCaseTy env ne e ct nmLblOffL mbRest sel = acoreSatSelsCasesTy env ne e [(ct,nmLblOffL,mbRest,sel)]
{-# INLINE acoreSatSelsCaseTy #-}
{-# LINE 272 "src/ehc/AbstractCore/Utils.chs" #-}
-- | Make a case expr from a single alternative with a single field,
-- | the alternative given by their tag + field (name/offset) + rest (for extensible records) + alt expr,
-- | the fields (and alternatives) are saturated according to the tag + rest info
acoreExprSatSelCaseTy :: (Eq bcat, AbstractCore e b bound boundmeta bcat t p pr pf a) => RCEEnv' e b ba t -> Maybe (HsName,t) -> e -> CTag -> HsName -> {- HsName -> -} Int -> MbPatRest' pr -> e
acoreExprSatSelCaseTy env ne e ct n {- lbl -} off mbRest = acoreSatSelsCaseTy env ne e ct [(n,acoreTyErr $ "acoreExprSatSelCaseTy: " ++ show n,{-lbl,-}off)] mbRest (acoreVar n)
acoreExprSatSelCase :: (Eq bcat, AbstractCore e b bound boundmeta bcat t p pr pf a) => RCEEnv' e b ba t -> Maybe (HsName) -> e -> CTag -> HsName -> {- HsName -> -} Int -> MbPatRest' pr -> e
acoreExprSatSelCase env ne e ct n {- lbl -} off mbRest = acoreExprSatSelCaseTy env (acoreTyErrLift "acoreExprSatSelCase" ne) e ct n {- lbl -} off mbRest
{-# INLINE acoreExprSatSelCase #-}
{-# LINE 302 "src/ehc/AbstractCore/Utils.chs" #-}
acoreMatchStringTy :: (Eq bcat, AbstractCore e b bound boundmeta bcat t p pr pf a) => RCEEnv' e b ba t -> String -> t -> e -> e -> e -> e
acoreMatchStringTy env str ty ok fail e
= acoreLet1PlainTy x ty e
$ foldr (\(c,ns@(_,xh,_)) ok
-> matchCons ns
$ acoreMatchChar opts (Just $ hsnUniqifyEval xh) c (acoreVar xh) ok fail
)
(matchNil xt ok)
$ zip str nms
where env' = env {rceCaseCont = fail}
matchCons (x,xh,xt) e = acoreSatSelsCaseTy env' (Just (hsnUniqifyEval x,ty)) (acoreVar x) constag [(xh,acoreTyErr "acoreMatchStringTy.hd",0),(xt,acoreTyErr "acoreMatchStringTy.tl",1)] (Just (acorePatRestEmpty,2)) e
matchNil x e = acoreSatSelsCaseTy env' (Just (hsnUniqifyEval x,ty)) (acoreVar x) niltag [] (Just (acorePatRestEmpty,0)) e
constag = ctagCons opts
niltag = ctagNil opts
opts = rceEHCOpts env
(nms@((x,_,_):_),(xt,_,_))
= fromJust $ initlast $ snd
$ foldr (\n (nt,l) -> (n,(n,hsnUniqifyStr HsNameUniqifier_Field "h" n,nt):l)) (hsnUnknown,[])
$ take (length str + 1) $ hsnLclSupplyWith (mkHNmHidden "l")
{-# LINE 324 "src/ehc/AbstractCore/Utils.chs" #-}
acoreMatchTupleTy :: (Eq bcat, AbstractCore e b bound boundmeta bcat t p pr pf a) => RCEEnv' e b ba t -> [HsName] -> t -> e -> e -> e
acoreMatchTupleTy env fldNmL ty ok e
= acoreLet1PlainTy x ty e
$ acoreSatSelsCaseTy env (Just (hsnUniqifyEval x,ty)) (acoreVar x) CTagRec (zipWith (\f o -> (f,acoreTyErr $ "acoreMatchTupleTy: " ++ show f,o)) fldNmL [0..]) (Just (acorePatRestEmpty,length fldNmL)) ok
where x = mkHNmHidden "x"
{-# LINE 336 "src/ehc/AbstractCore/Utils.chs" #-}
data RCESplitCateg
= RCESplitVar UIDS
| RCESplitCon
| RCESplitConMany
| RCESplitConst
| RCESplitIrrefutable
| RCESplitBoolExpr
deriving Eq
rceSplitMustBeOnItsOwn :: RCESplitCateg -> Bool
rceSplitMustBeOnItsOwn RCESplitConMany = True
rceSplitMustBeOnItsOwn RCESplitIrrefutable = True
rceSplitMustBeOnItsOwn _ = False
{-# LINE 354 "src/ehc/AbstractCore/Utils.chs" #-}
rceSplit :: (RAlt' e t b pr -> RCESplitCateg) -> RCEAltL' e t b pr -> [RCEAltL' e t b pr]
rceSplit f [] = []
rceSplit f [x] = [[x]]
rceSplit f (x:xs@(x':_))
| xcateg == f x'
&& not (rceSplitMustBeOnItsOwn xcateg)
= let (z:zs) = rceSplit f xs
in (x:z) : zs
| otherwise
= [x] : rceSplit f xs
where xcateg = f x
{-# LINE 368 "src/ehc/AbstractCore/Utils.chs" #-}
-- | Add bindings from the name n of each alt to nm, to take care of different namings
rceRebinds :: (Eq bcat, AbstractCore e b bound boundmeta bcat t p pr pf a) => Bool -> (HsName,t) -> RCEAltL' e t b pr -> [b]
rceRebinds origOnly (nm,ty) alts
= [ acoreBind1Ty n ty (acoreVar nm) | pn <- raltLPatNms alts, alsoUniq || rpatNmIsOrig pn, let n = rpatNmNm pn, n /= nm ]
where alsoUniq = not origOnly
{-# LINE 376 "src/ehc/AbstractCore/Utils.chs" #-}
rceMatchVar :: (Eq bcat, AbstractCore e b bound boundmeta bcat t p pr pf a, CSubstitutable e b ba t e) => RCEEnv' e b ba t -> [(HsName,t)] -> RCEAltL' e t b pr -> e
rceMatchVar env ((arg,ty):args') alts
= remMatch
where remMatch
= rceMatchTy env args'
[ RAlt_Alt remPats (mk $ acoreLet acoreBindcategPlain (rceRebinds True (arg',ty) [a]) e) f
| a@(RAlt_Alt (RPat_Var _ _ mustEval : remPats) e f) <- alts
, let (arg',mk) = if mustEval
then let argStrict = hsnUniqify HsNameUniqifier_Strict arg
in (argStrict,acoreLet1StrictTy argStrict ty (acoreVar arg))
else (arg,id)
]
rceMatchIrrefutable :: (Eq bcat, AbstractCore e b bound boundmeta bcat t p pr pf a, CSubstitutable e b ba t e) => RCEEnv' e b ba t -> [(HsName,t)] -> RCEAltL' e t b pr -> e
rceMatchIrrefutable env (argty@(arg,ty):args') alts@[RAlt_Alt (RPat_Irrefutable n _ b : remPats) e f]
= acoreLet acoreBindcategPlain (rceRebinds False argty alts) $ acoreLet acoreBindcategPlain b remMatch
where remMatch = rceMatchTy env args' [RAlt_Alt remPats e f]
rceMkConAltAndSubAlts :: (Eq bcat, AbstractCore e b bound boundmeta bcat t p pr pf a, CSubstitutable e b ba t e) => RCEEnv' e b ba t -> [(HsName,t)] -> RCEAltL' e t b pr -> a
rceMkConAltAndSubAlts env ((arg,ty):args) alts@(alt:_)
= acoreAlt altPat (acoreLet acoreBindcategPlain (rceRebinds True (arg,ty) alts) subMatch)
where (subAlts,subAltSubs)
= unzip
[ ( RAlt_Alt (pats ++ ps) e f
, map (\p -> let n = rpatNmNm (rcpPNm p) in (n,rcpTy p)) pats
)
| (RAlt_Alt (RPat_Con _ _ _ (RPatConBind_One _ pbinds) : ps) e f) <- alts
, let pats = [ p | (RPatFld_Fld _ _ _ p) <- pbinds ]
]
subMatch
= rceMatchTy env (subAltSub ++ args) subAlts
where subAltSub = zipWith (\(_,t) (n,ni) -> (ni,t)) (head subAltSubs) altNmIntroAssocL
(altPat, altNmIntroAssocL)
= case alt of
RAlt_Alt (RPat_Con n _ t (RPatConBind_One r pbL) : _) _ _
-> (acorePatCon t r pbL', nmIntroAssocL)
where (pbL',nmIntroAssocL)
= unzip
[ ( acorePatFldTy (rcpTy p) (l,o) introNm -- nm
, (nm, introNm)
)
| (RPatFld_Fld l o n p, inx) <- zip pbL [(0 :: Int) ..]
, let nm = rpatNmNm $ rcpPNm p
, let introNm = hsnUniqifyInt HsNameUniqifier_Field inx nm
]
tyerr n = acoreTyErr ("rceMkConAltAndSubAlts: " ++ show n)
rceMatchCon :: (Eq bcat, AbstractCore e b bound boundmeta bcat t p pr pf a, CSubstitutable e b ba t e) => RCEEnv' e b ba t -> [(HsName,t)] -> RCEAltL' e t b pr -> e
rceMatchCon env ((arg,ty):args) alts
= acoreStrictSatCaseTy env (Just (arg',ty)) (acoreVar arg) alts'
where arg' = hsnUniqifyEval arg
alts' = map (rceMkConAltAndSubAlts env ((arg',ty):args))
$ groupSortOn (ctagTag . rcaTag)
$ filter (not . null . rcaPats)
$ alts
rceMatchConMany :: (Eq bcat, AbstractCore e b bound boundmeta bcat t p pr pf a, CSubstitutable e b ba t e) => RCEEnv' e b ba t -> [(HsName,t)] -> RCEAltL' e t b pr -> e
rceMatchConMany env ((arg,ty):args) [RAlt_Alt (RPat_Con n _ t (RPatConBind_Many bs) : ps) e f]
= acoreLet1StrictInTy arg' ty (acoreVar arg)
(\_ -> foldr (\mka e -> rceMatchTy env [(arg',ty)] (mka e)) (rceMatchTy env ((arg',ty):args) altslast) altsinit)
where arg' = hsnUniqifyEval arg
altsinit = [ \e -> [RAlt_Alt (RPat_Con n ty t b : []) e f] | b <- bsinit ]
altslast = [RAlt_Alt (RPat_Con n ty t blast : ps) e f]
(bsinit,blast) = panicJust "rceMatchConMany" $ initlast bs
rceMatchConst :: (Eq bcat, AbstractCore e b bound boundmeta bcat t p pr pf a, CSubstitutable e b ba t e) => RCEEnv' e b ba t -> [(HsName,t)] -> RCEAltL' e t b pr -> e
rceMatchConst env ((arg,ty):args) alts
= acoreLet1StrictInTy arg' ty (acoreVar arg) (\n -> acoreLet cat (rceRebinds True (arg,ty) alts) (acoreCaseDflt n alts' Nothing {-(rceCaseCont env)-}))
where arg' = hsnUniqifyEval arg
alts' = [ acoreAlt (acoreRPat2Pat p) (cSubstApp (rceCaseFailSubst env) e {- tcSubstCaseAltFail (rceEHCOpts env) (rceCaseFailSubst env) e -}) | (RAlt_Alt (p:_) e _) <- alts ]
cat = acoreBindcategPlain
{-# LINE 450 "src/ehc/AbstractCore/Utils.chs" #-}
rceMatchBoolExpr :: (Eq bcat, AbstractCore e b bound boundmeta bcat t p pr pf a, CSubstitutable e b ba t e) => RCEEnv' e b ba t -> [(HsName,t)] -> RCEAltL' e t b pr -> e
rceMatchBoolExpr env aargs@((arg,_):args) alts
= foldr (\(n,c,t) f -> acoreIf (rceEHCOpts env) (Just n) c t f) (rceCaseCont env) alts'
where alts' = map (\(u, alts@(RAlt_Alt (RPat_BoolExpr _ _ b _ : _) _ _ : _))
-> ( hsnUniqifyInt HsNameUniqifier_Evaluated u arg
, acoreApp b [acoreVar arg]
, rceMatchTy env args [ RAlt_Alt remPats e f | (RAlt_Alt (RPat_BoolExpr _ _ _ _ : remPats) e f) <- alts ]
) )
$ zip [0..]
$ groupSortOn (rcpMbConst . head . rcaPats)
$ filter (not . null . rcaPats)
$ alts
{-# LINE 465 "src/ehc/AbstractCore/Utils.chs" #-}
rceMatchSplits :: (Eq bcat, AbstractCore e b bound boundmeta bcat t p pr pf a, CSubstitutable e b ba t e) => RCEEnv' e b ba t -> [(HsName,t)] -> RCEAltL' e t b pr -> e
rceMatchSplits env args alts@(alt:_)
| raltIsVar alt = rceMatchVar env args alts
| raltIsConst alt = rceMatchConst env args alts
| raltIsIrrefutable alt = rceMatchIrrefutable env args alts
| raltIsBoolExpr alt = rceMatchBoolExpr env args alts
| raltIsConMany alt = rceMatchConMany env args alts
| otherwise = rceMatchCon env args alts
{-# LINE 479 "src/ehc/AbstractCore/Utils.chs" #-}
rceMatchTy :: (Eq bcat, AbstractCore e b bound boundmeta bcat t p pr pf a, CSubstitutable e b ba t e) => RCEEnv' e b ba t -> [(HsName,t)] -> RCEAltL' e t b pr -> e
rceMatchTy env [] [] = rceCaseCont env
rceMatchTy env [] alts
= case [ e | (RAlt_Alt [] e _) <- alts ] of
(e:_) -> cSubstApp (rceCaseFailSubst env) e -- tcSubstCaseAltFail (rceEHCOpts env) (rceCaseFailSubst env) e
_ -> rceCaseCont env
rceMatchTy env args alts
= foldr
(\alts e
-> case acoreExprMbVar e of
Just _
-> rceMatchSplits (rceUpdEnv e env) args alts
_ -> acoreLet1PlainTy nc (rcpTy pc) e
$ rceMatchSplits (rceUpdEnv (acoreVar nc) env) args alts
where pc = rcaPat $ head alts
nc = hsnUniqify HsNameUniqifier_CaseContinuation (rpatNmNm $ rcpPNm pc)
)
(rceCaseCont env)
$ (rceSplit (\a -> if raltIsVar a then RCESplitVar (raaFailS a)
else if raltIsConst a then RCESplitConst
else if raltIsIrrefutable a then RCESplitIrrefutable
else if raltIsBoolExpr a then RCESplitBoolExpr
else if raltIsConMany a then RCESplitConMany
else RCESplitCon
) alts)
{-# LINE 514 "src/ehc/AbstractCore/Utils.chs" #-}
rceUpdEnv :: e -> RCEEnv' e b ba t -> RCEEnv' e b ba t
rceUpdEnv e env
= env { rceCaseFailSubst = Map.union (acoreCSubstFromUidExprL [ (i,e) | i <- Set.toList (rceCaseIds env) ])
$ rceCaseFailSubst env
, rceCaseCont = e
}
{-# LINE 527 "src/ehc/AbstractCore/Utils.chs" #-}
acoreCSubstFromVarMpImpls :: (AbstractCore e b bound boundmeta bcat t p pr pf a) => VarMp -> CSubst' e b ba t
acoreCSubstFromVarMpImpls c
= acoreCSubstFromUidImplsL
[ (iv,(acoreCoeImplsApp i,acoreCoeImplsLam acoreCoeId i))
| (iv,VMIImpls i) <- varmpToAssocL c, let (_,mbTl) = implsPredsMbTail i, isNothing mbTl
]
{-# LINE 540 "src/ehc/AbstractCore/Utils.chs" #-}
acoreRPatBindL2BindL :: (Eq bcat, AbstractCore e b bound boundmeta bcat t p pr pf a) => RCEEnv' e b ba t -> Bool -> HsName -> CTag -> MbPatRest' pr -> AssocL (RPatFld' e t b pr) (Maybe Int) -> [b]
acoreRPatBindL2BindL env hasSub parNm ct rest pbL
= concat
$ map (\(RPatFld_Fld l o _ p,mbOff)
-> let b n = [acoreBind1CatTy acoreBindcategPlain n (rcpTy p) (mkc n mbOff)]
pn = parNm
pn' = hsnUniqifyEval pn
mkc n (Just o) = acoreExprSatSelCaseTy env (Just (pn',ty pn')) (acoreVar pn) ct n {- l -} o rest
mkc n Nothing = acoreSelCaseTy env (Just (pn',ty pn')) (acoreVar pn) ct n {- l -} o rest
ty n = acoreTyErr ("acoreRPatBindL2BindL: " ++ show n)
in case rcpPNm p of
RPatNmOrig n -> b n
RPatNmUniq n | hasSub -> b n
_ -> []
)
$ pbL