module DDC.Core.Transform.Snip
(Snip(..))
where
import DDC.Core.Analysis.Arity
import DDC.Core.Module
import DDC.Core.Exp
import DDC.Core.Compounds
import qualified DDC.Core.Transform.LiftX as L
import qualified DDC.Type.Compounds as T
class Snip (c :: * -> *) where
snip :: Ord n
=> Bool
-> c n
-> c n
instance Snip (Module a) where
snip bOver mm
=
let arities = aritiesOfModule mm
body' = snipX bOver arities (moduleBody mm) []
in mm { moduleBody = body' }
instance Snip (Exp a) where
snip bOver x
=
snipX bOver emptyArities x []
snipX
:: Ord n
=> Bool
-> Arities n
-> Exp a n
-> [(Exp a n, a)]
-> Exp a n
snipX bOver arities x args
| XApp a fun arg <- x
= snipX bOver arities fun $ (snipX bOver arities arg [], a) : args
| null args
= enterX bOver arities x
| otherwise
= buildNormalisedApp bOver arities (enterX bOver arities x) args
enterX bOver arities xx
= let down ars e
= snipX bOver (extendsArities arities ars) e []
in case xx of
XApp{}
-> error "DDC.Core.Transform.Snip: snipX shouldn't give us an XApp"
XVar{} -> xx
XCon{} -> xx
XType{} -> xx
XWitness{} -> xx
XLAM a b e
-> XLAM a b (down [(b,0)] e)
XLam a b e
-> XLam a b (down [(b,0)] e)
XLet a (LLet m b x1) x2
-> let x1' = down [] x1
x2' = down [(b, arityOfExp' x1')] x2
in XLet a (LLet m b x1') x2'
XLet a (LRec lets) x2
-> let bs = map fst lets
xs = map snd lets
ars = zip bs (map arityOfExp' xs)
xs' = map (down ars) xs
x2' = down ars x2
in XLet a (LRec $ zip bs xs') x2'
XLet a (LLetRegions b bs) x2
-> let ars = zip bs (repeat 0)
in XLet a (LLetRegions b bs) (down ars x2)
XLet a (LWithRegion b) z2
-> XLet a (LWithRegion b) (down [] z2)
XCase a e alts
| isAtom e
-> let e' = down [] e
alts' = map (\(AAlt pat ae)
-> AAlt pat (down (aritiesOfPat pat) ae)) alts
in XCase a e' alts'
| otherwise
-> let e' = down [] e
alts' = [AAlt pat (down (aritiesOfPat pat) ae) | AAlt pat ae <- alts]
in XLet a (LLet LetStrict (BAnon (T.tBot T.kData)) e')
(XCase a (XVar a $ UIx 0)
(map (L.liftX 1) alts'))
XCast a c e
-> XCast a c (down [] e)
buildNormalisedApp
:: Ord n
=> Bool
-> Arities n
-> Exp a n
-> [(Exp a n,a)]
-> Exp a n
buildNormalisedApp _bOver _ f0 [] = f0
buildNormalisedApp bOver arities f0 args@( (_, annot) : _)
= make annot f0 args
where
tBot' = T.tBot T.kData
f0Arity
= case f0 of
XVar _ b
| Just arity <- getArity arities b
-> max arity 1
_ -> max (arityOfExp' f0) 1
make a xFun xsArgs
| isAtom xFun
= buildNormalisedFunApp bOver a f0Arity xFun xsArgs
| otherwise
= XLet a (LLet LetStrict (BAnon tBot') xFun)
(buildNormalisedFunApp bOver a f0Arity
(XVar a (UIx 0))
[ (L.liftX 1 x, a') | (x, a') <- xsArgs])
buildNormalisedFunApp
:: Ord n
=> Bool
-> a
-> Int
-> Exp a n
-> [(Exp a n, a)]
-> Exp a n
buildNormalisedFunApp bOver an funArity xFun xsArgs
= let tBot' = T.tBot T.kData
argss = splitArgs xsArgs
xsLets = [ (x, a)
| (_, a, _, Just x) <- argss]
nLets = length xsLets
xsLets' = [ (L.liftX n x, a)
| (x, a) <- xsLets
| (n :: Int) <- [0..] ]
xFun' = L.liftX nLets xFun
xsArgs' = [if liftMe
then (L.liftX nLets xArg, a)
else (xArg, a)
| (xArg, a, liftMe, _) <- argss]
xFunApps
| bOver
, length xsArgs' > funArity
, (xsSat, xsOver) <- splitAt funArity xsArgs'
= XLet an (LLet LetStrict (BAnon tBot')
(makeXAppsWithAnnots xFun' xsSat))
(makeXAppsWithAnnots
(XVar an (UIx 0))
[ (L.liftX 1 x, a) | (x, a) <- xsOver ])
| otherwise
= makeXAppsWithAnnots
xFun'
xsArgs'
in foldr (\(x, a) x' -> XLet a x x')
xFunApps
[ (LLet LetStrict (BAnon tBot') x, a)
| (x, a) <- xsLets' ]
splitArgs
:: Ord n
=> [(Exp a n, a)]
-> [( Exp a n
, a
, Bool
, Maybe (Exp a n))]
splitArgs args
= reverse $ go 0 $ reverse args
where
go _n [] = []
go n ((xArg, a) : xsArgs)
| isAtom xArg
= (xArg, a, True, Nothing) : go n xsArgs
| otherwise
= (XVar a (UIx n), a, False, Just xArg) : go (n + 1) xsArgs
isAtom :: Ord n => Exp a n -> Bool
isAtom xx
= case xx of
XVar{} -> True
XCon{} -> True
XType{} -> True
XWitness{} -> True
XCast _ _ x -> isAtom x
_ -> False
arityOfExp' :: Ord n => Exp a n -> Int
arityOfExp' xx
= case arityOfExp xx of
Nothing -> 0
Just a -> a