module DDC.Core.Flow.Transform.Slurp
( slurpProcesses
, slurpOperator
, isSeriesOperator
, isVectorOperator)
where
import DDC.Core.Flow.Transform.Slurp.Operator
import DDC.Core.Flow.Transform.Slurp.Error
import DDC.Core.Flow.Prim
import DDC.Core.Flow.Context
import DDC.Core.Flow.Process
import DDC.Core.Flow.Compounds
import DDC.Core.Flow.Exp
import DDC.Core.Transform.Deannotate
import DDC.Core.Module
import qualified DDC.Type.Env as Env
import DDC.Type.Env (TypeEnv)
import Data.List
slurpProcesses :: Module () Name -> Either Error [Process]
slurpProcesses mm
= slurpProcessesX (deannotate (const Nothing) $ moduleBody mm)
slurpProcessesX :: Exp () Name -> Either Error [Process]
slurpProcessesX xx
= case xx of
XLet lts x'
-> do ps1 <- slurpProcessesLts lts
ps2 <- slurpProcessesX x'
return $ ps1 ++ ps2
_
| xx == xUnit -> Right []
| otherwise -> Left $ ErrorBadProcess xx
slurpProcessesLts :: Lets () Name -> Either Error [Process]
slurpProcessesLts (LRec binds)
= sequence [slurpProcessLet b x | (b, x) <- binds]
slurpProcessesLts (LLet b x)
= sequence [slurpProcessLet b x]
slurpProcessesLts _
= return []
slurpProcessLet
:: Bind Name
-> Exp () Name
-> Either Error Process
slurpProcessLet (BName n t) xx
| (snd $ takeTFunAllArgResult t) == tProcess
, Just (fbs, xBody) <- takeXLamFlags xx
= let
(fbts, fbvs) = partition fst fbs
bts = map snd fbts
tsRate = filter (\b -> typeOfBind b == kRate) bts
ctxParam = map (ContextRate . TVar . UName)
$ map (\(BName nRate _) -> nRate)
$ tsRate
bvs = map snd fbvs
in do
(ctxLocal, ops)
<- slurpProcessX Env.empty xBody
return $ Process
{ processName = n
, processParamTypes = bts
, processParamValues = bvs
, processContexts = ctxParam ++ ctxLocal
, processOperators = ops }
slurpProcessLet _ xx
= Left (ErrorBadProcess xx)
slurpProcessX
:: TypeEnv Name
-> ExpF
-> Either Error
( [Context]
, [Operator])
slurpProcessX tenv xx
| XLet (LLet b x) xMore <- xx
= do
(ctxHere, opsHere) <- slurpBindingX tenv b x
let tenv'
| typeOfBind b == tProcess = Env.extend b tenv
| otherwise = tenv
(ctxMore, opsMore) <- slurpProcessX tenv' xMore
return ( ctxHere ++ ctxMore
, opsHere ++ opsMore)
slurpProcessX tenv xx
| XVar u <- xx
, Just t <- Env.lookup u tenv
, t == tProcess
= return ([], [])
| Just (NameOpSeries OpSeriesJoin, [_, _])
<- takeXPrimApps xx
= return ([], [])
| otherwise
= Left (ErrorBadProcess xx)
slurpBindingX
:: TypeEnv Name
-> BindF
-> ExpF
-> Either
Error
( [Context]
, [Operator])
slurpBindingX tenv b1 xx
| XLet (LLet b2 x2) xMore <- xx
= do
(ctxHere, opsHere) <- slurpBindingX tenv b2 x2
let tenv'
| typeOfBind b2 == tProcess = Env.extend b2 tenv
| otherwise = tenv
(ctxMore, opsMore) <- slurpBindingX tenv' b1 xMore
return ( ctxHere ++ ctxMore
, opsHere ++ opsMore)
slurpBindingX tenv b
( takeXPrimApps
-> Just ( NameOpSeries (OpSeriesMkSel 1)
, [ XType tK1
, XVar uFlags
, XLAM (BName nR kR) (XLam bSel xBody)]))
| kR == kRate
= do
(ctxInner, osInner)
<- slurpBindingX tenv b xBody
let UName nFlags = uFlags
let nFlagsUse = NameVarMod nFlags "use"
let uFlagsUse = UName nFlagsUse
let bFlagsUse = BName nFlagsUse (tSeries tK1 tBool)
let opId = OpId
{ opResultSeries = bFlagsUse
, opInputRate = tK1
, opInputSeries = uFlags
, opElemType = tBool }
let context = ContextSelect
{ contextOuterRate = tK1
, contextInnerRate = TVar (UName nR)
, contextFlags = uFlagsUse
, contextSelector = bSel }
return (context : ctxInner, opId : osInner)
slurpBindingX tenv b
( takeXPrimApps
-> Just ( NameOpSeries OpSeriesMkSegd
, [ XType tK1
, XVar uLens
, XLAM (BName nK2 kR) (XLam bSegd xBody)]))
| kR == kRate
= do
(ctxInner, osInner)
<- slurpBindingX tenv b xBody
let UName nLens = uLens
let nLensUse = NameVarMod nLens "use"
let uLensUse = UName nLensUse
let bLensUse = BName nLensUse (tSeries tK1 tNat)
let opId = OpId
{ opResultSeries = bLensUse
, opInputRate = tK1
, opInputSeries = uLens
, opElemType = tNat }
let context = ContextSegment
{ contextOuterRate = tK1
, contextInnerRate = TVar (UName nK2)
, contextLens = uLensUse
, contextSegd = bSegd }
return (context : ctxInner, opId : osInner)
slurpBindingX _ b xx
| Just op <- slurpOperator b xx
= return ([], [op])
slurpBindingX tenv _ xx
| XVar u <- xx
, Just t <- Env.lookup u tenv
, t == tProcess
= return ([], [])
| Just (NameOpSeries OpSeriesJoin, [_, _])
<- takeXPrimApps xx
= return ([], [])
| otherwise
= Left (ErrorBadOperator xx)