module DDC.Core.Transform.Flatten
(flatten)
where
import DDC.Core.Transform.LiftT
import DDC.Core.Transform.TransformUpX
import DDC.Core.Transform.AnonymizeX
import DDC.Core.Transform.LiftX
import DDC.Core.Exp
import DDC.Core.Compounds
import DDC.Type.Predicates
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 (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@(XLet a2 (LPrivate b2 mt bs2) x2))
x1)
| all isBName b2
= flatten1
$ XLet a1 (LLet b1
(anonymizeX inner))
x1
| otherwise
= let x1' = liftAcrossT [] b2
$ liftAcrossX [b1] bs2 x1
in XLet a2 (LPrivate b2 mt bs2)
$ flatten1
$ XLet a1 (LLet (zapX 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
liftAcrossT :: Ord n => [Bind n] -> [Bind n] -> Exp a n -> Exp a n
liftAcrossT bsDepth bsLevels x
= let depth = length [b | b@(BAnon _) <- bsDepth]
levels = length [b | b@(BAnon _) <- bsLevels]
in liftAtDepthT levels depth x
zapX :: Bind n -> Bind n
zapX b = replaceTypeOfBind (tBot kData) b