module DDC.Core.Salt.Transfer
(transferModule)
where
import DDC.Core.Salt.Convert.Base
import DDC.Core.Salt.Compounds
import DDC.Core.Salt.Name
import DDC.Core.Salt.Env
import DDC.Core.Module
import DDC.Core.Exp.Annot
import DDC.Core.Check (AnTEC(..))
import Data.Map (Map)
import qualified Data.Map as Map
transferModule
:: Module (AnTEC a Name) Name
-> Either (Error (AnTEC a Name))
(Module (AnTEC a Name) Name)
transferModule mm@ModuleCore{}
| XLet a (LRec bxs) x1 <- moduleBody mm
= let bxs' = map transLet bxs
in Right $ mm { moduleBody = XLet a (LRec bxs') x1 }
| otherwise
= Left (ErrorNoTopLevelLetrec mm)
transLet :: (Bind Name, Exp (AnTEC a Name) Name)
-> (Bind Name, Exp (AnTEC a Name) Name)
transLet (BName n t, x)
= let tails = Map.singleton n t
x' = transSuper tails x
in (BName n t, x')
transLet tup
= tup
transSuper
:: Map Name (Type Name)
-> Exp (AnTEC a Name) Name
-> Exp (AnTEC a Name) Name
transSuper tails xx
= let down = transSuper tails
in case xx of
XVar a _ -> xReturn a (annotType a) xx
XCon a _ -> xReturn a (annotType a) xx
XLAM a b x -> XLAM a b $ down x
XLam a b x -> XLam a b $ down x
XApp{}
| Just (xv@(XVar a (UName n)), args) <- takeXApps xx
, Just tF <- Map.lookup n tails
, (xsArgsType, xsArgsMore) <- span isXType args
, (xsArgsWit, xsArgsVal) <- span isXWitness xsArgsMore
, not $ any isXType xsArgsVal
, not $ any isXWitness xsArgsVal
, (_, tsValArgs, tResult) <- takeTFunWitArgResult $ eraseTForalls tF
-> let arity = length xsArgsVal
p = PrimCallTail arity
u = UPrim (NamePrimOp (PrimCall p)) (typeOfPrimCall p)
in xApps a (XVar a u)
$ (map (XType a) (tsValArgs ++ [tResult]))
++ [xApps a xv (xsArgsType ++ xsArgsWit)]
++ xsArgsVal
XApp a x1 x2
-> let x1' = transX tails x1
x2' = transX tails x2
in addReturnX a (annotType a) (XApp a x1' x2')
XLet a lts x -> XLet a (transL tails lts) (down x)
XCase a x alts -> XCase a (transX tails x) (map (transA tails) alts)
XCast a c x -> XCast a c (transSuper tails x)
XType{} -> xx
XWitness{} -> xx
addReturnX :: a -> Type Name
-> Exp a Name -> Exp a Name
addReturnX a t xx
| Just (NamePrimOp p, _) <- takeXPrimApps xx
, PrimControl{} <- p
= xx
| otherwise
= xReturn a t xx
transL :: Map Name (Type Name)
-> Lets (AnTEC a Name) Name
-> Lets (AnTEC a Name) Name
transL tails lts
= case lts of
LLet b x -> LLet b (transX tails x)
LRec bxs -> LRec [(b, transX tails x) | (b, x) <- bxs]
LPrivate{} -> lts
transA :: Map Name (Type Name)
-> Alt (AnTEC a Name) Name
-> Alt (AnTEC a Name) Name
transA tails aa
= case aa of
AAlt p x -> AAlt p (transSuper tails x)
transX :: Map Name (Type Name)
-> Exp (AnTEC a Name) Name
-> Exp (AnTEC a Name) Name
transX tails xx
= let down = transX tails
in case xx of
XVar{} -> xx
XCon{} -> xx
XLAM{} -> xx
XLam{} -> xx
XApp a x1 x2 -> XApp a (down x1) (down x2)
XLet{} -> xx
XCase{} -> xx
XCast{} -> xx
XType{} -> xx
XWitness{} -> xx