module DDC.Core.Transform.LiftX
( liftX, liftAtDepthX
, lowerX, lowerAtDepthX
, MapBoundX(..))
where
import DDC.Core.Exp
liftAtDepthX
:: MapBoundX c n
=> Int
-> Int
-> c n
-> c n
liftAtDepthX n d
=
mapBoundAtDepthX liftU d
where
liftU d' u
= case u of
UName{} -> u
UPrim{} -> u
UIx i
| d' <= i -> UIx (i + n)
| otherwise -> u
liftX :: MapBoundX c n => Int -> c n -> c n
liftX n xx = liftAtDepthX n 0 xx
lowerAtDepthX
:: MapBoundX c n
=> Int
-> Int
-> c n
-> c n
lowerAtDepthX n d
=
mapBoundAtDepthX liftU d
where
liftU d' u
= case u of
UName{} -> u
UPrim{} -> u
UIx i
| d' <= i -> UIx (i n)
| otherwise -> u
lowerX :: MapBoundX c n => Int -> c n -> c n
lowerX n xx = lowerAtDepthX n 0 xx
class MapBoundX (c :: * -> *) n where
mapBoundAtDepthX
:: (Int -> Bound n -> Bound n)
-> Int
-> c n
-> c n
instance MapBoundX Bound n where
mapBoundAtDepthX f d u
= f d u
instance MapBoundX (Exp a) n where
mapBoundAtDepthX f d xx
= let down = mapBoundAtDepthX f d
in case xx of
XVar a u -> XVar a (f d u)
XCon{} -> xx
XApp a x1 x2 -> XApp a (down x1) (down x2)
XLAM a b x -> XLAM a b (down x)
XLam a b x -> XLam a b (mapBoundAtDepthX f (d + countBAnons [b]) x)
XLet a lets x
-> let (lets', levels) = mapBoundAtDepthXLets f d lets
in XLet a lets' (mapBoundAtDepthX f (d + levels) x)
XCase a x alts -> XCase a (down x) (map down alts)
XCast a cc x -> XCast a (down cc) (down x)
XType{} -> xx
XWitness a w -> XWitness a (down w)
instance MapBoundX (Witness a) n where
mapBoundAtDepthX f d ww
= let down = mapBoundAtDepthX f d
in case ww of
WVar a u -> WVar a (down u)
WCon _ _ -> ww
WApp a w1 w2 -> WApp a (down w1) (down w2)
WJoin a w1 w2 -> WJoin a (down w1) (down w2)
WType _ _ -> ww
instance MapBoundX (Cast a) n where
mapBoundAtDepthX f d cc
= case cc of
CastWeakenEffect{}
-> cc
CastWeakenClosure xs
-> CastWeakenClosure (map (mapBoundAtDepthX f d) xs)
CastPurify w -> CastPurify w
CastForget w -> CastForget w
CastBox -> CastBox
CastRun -> CastRun
instance MapBoundX (Alt a) n where
mapBoundAtDepthX f d (AAlt p x)
= case p of
PDefault
-> AAlt PDefault (mapBoundAtDepthX f d x)
PData _ bs
-> let d' = d + countBAnons bs
in AAlt p (mapBoundAtDepthX f d' x)
mapBoundAtDepthXLets
:: (Int -> Bound n -> Bound n)
-> Int
-> Lets a n
-> (Lets a n, Int)
mapBoundAtDepthXLets f d lts
= case lts of
LLet b x
-> let inc = countBAnons [b]
x' = mapBoundAtDepthX f d x
in (LLet b x', inc)
LRec bs
-> let inc = countBAnons (map fst bs)
bs' = map (\(b,e) -> (b, mapBoundAtDepthX f (d+inc) e)) bs
in (LRec bs', inc)
LPrivate _b _ bs -> (lts, countBAnons bs)
LWithRegion _ -> (lts, 0)
countBAnons = length . filter isAnon
where isAnon (BAnon _) = True
isAnon _ = False