module DDC.Core.Transform.Flatten
(flatten)
where
import DDC.Core.Transform.TransformUpX
import DDC.Core.Transform.AnonymizeX
import DDC.Core.Transform.BoundX
import DDC.Core.Exp.Annot
import Data.Functor.Identity
flatten :: Ord n
=> (TransformUpMX Identity c)
=> c a n -> c a n
flatten
=
transformUpX' flatten1
flatten1
:: Ord n
=> Exp a n
-> Exp a n
flatten1 (XCast a1 CastRun (XLet a2 lts x2))
= XLet a2 lts $ flatten1 (XCast a1 CastRun x2)
flatten1 (XLet a1 (LLet b1
(XLet _ (LLet (BAnon _) def2) (XVar _ (UIx 0))))
x1)
= flatten1
$ XLet a1 (LLet b1 def2)
x1
flatten1 (XLet a1 (LLet b1
inner@(XLet a2 (LLet b2 def2) x2))
x1)
| isBName b2
= flatten1
$ XLet a1 (LLet b1
(anonymizeX inner))
x1
| otherwise
= let x1' = liftAcrossX [b1] [b2] x1
in XLet a2 (LLet b2 def2)
$ flatten1
$ XLet a1 (LLet b1 x2)
x1'
flatten1 (XLet a1 (LLet b1
inner@(XCase a2 x1 [AAlt p x2]))
x3)
| any isBName $ bindsOfPat p
= flatten1
$ XLet a1 (LLet b1
(anonymizeX inner))
x3
| otherwise
= let x3' = liftAcrossX [b1] (bindsOfPat p) x3
in XCase a2 x1
[AAlt p ( flatten1
$ XLet a1 (LLet b1 x2)
(anonymizeX x3'))]
flatten1 (XLet a1 llet1 x1)
= XLet a1 llet1 (flatten1 x1)
flatten1 (XCase a x1 alts)
= XCase a (flatten1 x1)
[AAlt p (flatten1 x) | AAlt p x <- alts ]
flatten1 x = x
liftAcrossX :: Ord n => [Bind n] -> [Bind n] -> Exp a n -> Exp a n
liftAcrossX bsDepth bsLevels x
= let depth = length [b | b@(BAnon _) <- bsDepth]
levels = length [b | b@(BAnon _) <- bsLevels]
in liftAtDepthX levels depth x