ddc-core-flow-0.4.3.1: DDC/Core/Flow/Prim/OpSeries.hs
module DDC.Core.Flow.Prim.OpSeries
( readOpSeries
, typeOpSeries
-- Compounds
, xSeriesOfRateVec)
where
import DDC.Core.Flow.Prim.KiConFlow
import DDC.Core.Flow.Prim.TyConFlow
import DDC.Core.Flow.Prim.TyConPrim
import DDC.Core.Flow.Prim.Base
import DDC.Core.Flow.Exp.Simple.Compounds
import DDC.Core.Flow.Exp.Simple.Exp
import DDC.Core.Transform.BoundT
import DDC.Data.Pretty
import Control.DeepSeq
import Data.List
import Data.Char
instance NFData OpSeries where
rnf !_ = ()
instance Pretty OpSeries where
ppr pf
= case pf of
OpSeriesRep -> text "srep" <> text "#"
OpSeriesReps -> text "sreps" <> text "#"
OpSeriesIndices -> text "sindices" <> text "#"
OpSeriesFill -> text "sfill" <> text "#"
OpSeriesGather -> text "sgather" <> text "#"
OpSeriesScatter -> text "sscatter" <> text "#"
OpSeriesMkSel 1 -> text "smkSel" <> text "#"
OpSeriesMkSel n -> text "smkSel" <> int n <> text "#"
OpSeriesMkSegd -> text "smkSegd" <> text "#"
OpSeriesMap 1 -> text "smap" <> text "#"
OpSeriesMap i -> text "smap" <> int i <> text "#"
OpSeriesPack -> text "spack" <> text "#"
OpSeriesGenerate -> text "sgenerate" <> text "#"
OpSeriesReduce -> text "sreduce" <> text "#"
OpSeriesFolds -> text "sfolds" <> text "#"
OpSeriesJoin -> text "pjoin" <> text "#"
OpSeriesRunProcess -> text "runProcess" <> text "#"
OpSeriesRunProcessUnit -> text "runProcessUnit" <> text "#"
OpSeriesRateVecsOfVectors n -> text "ratify" <> int n <> text "#"
OpSeriesSeriesOfRateVec -> text "series" <> text "#"
OpSeriesAppend -> text "sappend" <> text "#"
OpSeriesCross -> text "scross" <> text "#"
OpSeriesResizeProc -> text "presize" <> text "#"
OpSeriesResizeId -> text "rid" <> text "#"
OpSeriesResizeAppL -> text "rappl" <> text "#"
OpSeriesResizeAppR -> text "rappr" <> text "#"
OpSeriesResizeApp -> text "rapp" <> text "#"
OpSeriesResizeSel1 -> text "rsel1" <> text "#"
OpSeriesResizeSegd -> text "rsegd" <> text "#"
OpSeriesResizeCross -> text "rcross" <> text "#"
-- | Read a data flow operator name.
readOpSeries :: String -> Maybe OpSeries
readOpSeries str
| Just rest <- stripPrefix "smap" str
, (ds, "#") <- span isDigit rest
, not $ null ds
, arity <- read ds
= Just $ OpSeriesMap arity
| Just rest <- stripPrefix "smkSel" str
, (ds, "#") <- span isDigit rest
, not $ null ds
, arity <- read ds
, arity == 1
= Just $ OpSeriesMkSel arity
| Just rest <- stripPrefix "ratify" str
, (ds, "#") <- span isDigit rest
, not $ null ds
, arity <- read ds
= Just $ OpSeriesRateVecsOfVectors arity
| otherwise
= case str of
"srep#" -> Just $ OpSeriesRep
"sreps#" -> Just $ OpSeriesReps
"sindices#" -> Just $ OpSeriesIndices
"sgather#" -> Just $ OpSeriesGather
"smkSel#" -> Just $ OpSeriesMkSel 1
"smkSegd#" -> Just $ OpSeriesMkSegd
"smap#" -> Just $ OpSeriesMap 1
"spack#" -> Just $ OpSeriesPack
"sgenerate#" -> Just $ OpSeriesGenerate
"sreduce#" -> Just $ OpSeriesReduce
"sfolds#" -> Just $ OpSeriesFolds
"sfill#" -> Just $ OpSeriesFill
"sscatter#" -> Just $ OpSeriesScatter
"pjoin#" -> Just $ OpSeriesJoin
"runProcess#" -> Just $ OpSeriesRunProcess
"runProcessUnit#"->Just $ OpSeriesRunProcessUnit
"series#" -> Just $ OpSeriesSeriesOfRateVec
"sappend#" -> Just $ OpSeriesAppend
"scross#" -> Just $ OpSeriesCross
"presize#" -> Just $ OpSeriesResizeProc
"rid#" -> Just $ OpSeriesResizeId
"rappl#" -> Just $ OpSeriesResizeAppL
"rappr#" -> Just $ OpSeriesResizeAppR
"rapp#" -> Just $ OpSeriesResizeApp
"rsel1#" -> Just $ OpSeriesResizeSel1
"rsegd#" -> Just $ OpSeriesResizeSegd
"rcross#" -> Just $ OpSeriesResizeCross
_ -> Nothing
-- Types -----------------------------------------------------------------------
-- | Yield the type of a data flow operator,
-- or `error` if there isn't one.
typeOpSeries :: OpSeries -> Type Name
typeOpSeries op
= case takeTypeOpSeries op of
Just t -> t
Nothing -> error $ "ddc-core-flow.typeOpSeries: invalid op " ++ show op
-- | Yield the type of a data flow operator.
takeTypeOpSeries :: OpSeries -> Maybe (Type Name)
takeTypeOpSeries op
= case op of
-- Replicates -------------------------
-- rep :: [p : Proc] [k : Rate] [a : Data]
-- . a -> Series p k a
OpSeriesRep
-> Just $ tForalls [kProc, kRate, kData] $ \[tP, tR, tA]
-> tA `tFun` tSeries tP tR tA
-- reps :: [p : Proc]. [k1 k2 : Rate]. [a : Data]
-- . Segd k1 k2 -> Series p k1 a -> Series p k2 a
OpSeriesReps
-> Just $ tForalls [kProc, kRate, kRate, kData] $ \[tP, tK1, tK2, tA]
-> tSegd tK1 tK2 `tFun` tSeries tP tK1 tA `tFun` tSeries tP tK2 tA
-- Indices ------------------------------
-- indices :: [p : Proc]. [k1 k2 : Rate].
-- . Segd k1 k2 -> Series p k2 k1 Nat
OpSeriesIndices
-> Just $ tForalls [kProc, kRate, kRate] $ \[tP, tK1, tK2]
-> tSegd tK1 tK2 `tFun` tSeries tP tK2 tNat
-- Maps ---------------------------------
-- map :: [p : Proc]. [kR kL : Rate] [a b : Data]
-- . (a -> b) -> Series p kR kL a -> Series p kR kL b
OpSeriesMap 1
-> Just $ tForalls [kProc, kRate, kData, kData] $ \[tP, tKR, tA, tB]
-> (tA `tFun` tB)
`tFun` tSeries tP tKR tA
`tFun` tSeries tP tKR tB
-- mapN :: [p : Proc] [kR kL : Rate] [a0..aN : Data]
-- . (a0 -> .. aN) -> Series p kR kL a0 -> .. Series p kR kL aN
OpSeriesMap n
| n >= 2
, Just tWork <- tFunOfList
[ TVar (UIx i)
| i <- reverse [0..n] ]
, Just tBody <- tFunOfList
(tWork : [tSeries (TVar $ UIx $ n + 2) (TVar $ UIx $ n + 1)
(TVar $ UIx i)
| i <- reverse [0..n] ])
-> Just $ foldr TForall tBody
[ BAnon k | k <- kProc : kRate : replicate (n + 1) kData ]
-- Packs --------------------------------
-- pack :: [p : Proc]. [k1 k2 kL : Rate]. [a : Data]
-- . Sel2 k1 k2
-- -> Series p k1 kL a -> Series p k2 kL a
OpSeriesPack
-> Just $ tForalls [kProc, kRate, kRate, kData] $ \[tP, tK1, tK2, tA]
-> tSel1 tP tK1 tK2
`tFun` tSeries tP tK1 tA
`tFun` tSeries tP tK2 tA
-- Processes ----------------------------
-- join# :: [p : Proc]. [k : Rate]. [a b : Data].
-- . Process p k a
-- -> Process p k b
-- -> Process p k (a,b)
OpSeriesJoin
-> Just $ tForalls [kProc, kRate] $
\[tP, tK]
-> tProcess tP tK
`tFun` tProcess tP tK
`tFun` tProcess tP tK
-- mkSel1# :: [p : Proc]. [k1 kL : Rate]
-- . Series p k1 kL Bool#
-- -> ([k2 : Rate]. Sel1 p k1 k2 -> Process# p kL)
-- -> Process# p kL
OpSeriesMkSel 1
-> Just $ tForalls [kProc, kRate, kRate] $ \[tP, tK1, tKL]
-> tSeries tP tK1 tBool
`tFun` (tForall kRate $ \tK2
-> tSel1 (liftT 1 tP) (liftT 1 tK1) tK2 `tFun` tProcess (liftT 1 tP) (liftT 1 tKL))
`tFun` tProcess tP tKL
-- mkSegd# :: [p : Proc]. [k1 kL : Rate]
-- . Series# p k1 kL Nat#
-- -> ([k2 : Rate]. Segd# k1 k2 -> Process# p kL)
-- -> Process# p kL
OpSeriesMkSegd
-> Just $ tForalls [kProc, kRate] $ \[tP, tK1]
-> tSeries tP tK1 tNat
`tFun` (tForall kRate $ \tK2
-> tSegd (liftT 1 tK1) tK2 `tFun` tProcess (liftT 1 tP) (liftT 1 tK1))
`tFun` tProcess tP tK1
-- runProcess# :: [k : Rate]
-- .
-- ([p : Proc]. Unit -> Process p k)
-- -> Unit
OpSeriesRunProcess
-> Just $ tForalls [kRate] $ \[tK]
-> (tForall kProc $ \tP
-> tUnit `tFun` tProcess tP (liftT 1 tK))
`tFun` tUnit
-- runProcessUnit# :: [k : Rate]
-- .
-- ([p : Proc]. Unit -> Unit)
-- -> Unit
OpSeriesRunProcessUnit
-> Just $ tForalls [kRate] $ \[_]
-> (tForall kProc $ \_
-> tUnit `tFun` tUnit)
`tFun` tUnit
-- ratify0# :: [z : Data]
-- . Nat
-- -> ([k : Rate]. z)
-- -> z
OpSeriesRateVecsOfVectors 0
-> Just $ tForall kData $ \tA
-> tNat
`tFun` (tForall kRate $ \_ -> liftT 1 tA)
`tFun` tA
-- ratifyN# :: [a0..aN z : Data]
-- . Vector a0 .. Vector aN
-- -> ([k : Rate]. RateVec k a0 .. RateVec k aN -> z)
-- -> z
OpSeriesRateVecsOfVectors n
| tK <- TVar (UIx 0)
, Just tWork <- tFunOfList
$ [ tRateVec tK (TVar (UIx i))
| i <- reverse [2..n+1] ]
++[ TVar (UIx 1) ]
, tWork' <- TForall (BAnon kRate) tWork
, Just tBody <- tFunOfList
$ [ tVector (TVar (UIx i)) | i <- reverse [1..n] ]
++[ tWork', TVar (UIx 0) ]
-> Just $ foldr TForall tBody
[ BAnon k | k <- replicate (n+1) kData ]
-- series# :: [p : Proc]. [k : Rate]. [a : Data]
-- . RateVec k a -> Series p k a
OpSeriesSeriesOfRateVec
-> Just $ tForalls [kProc, kRate, kData] $ \[tP, tK, tA]
-> tRateVec tK tA `tFun` tSeries tP tK tA
-- sappend# :: [p : Proc]. [k1R k2R : Rate]. [a : Data]
-- . Series p k1R a -> Series p k2R a
-- -> Series p (k1R + k2R) a
OpSeriesAppend
-> Just $ tForalls [kProc, kRate, kRate, kData] $
\[tP, tK1, tK2, tA]
-> tSeries tP tK1 tA
`tFun` tSeries tP tK2 tA
`tFun` tSeries tP (tRateAppend tK1 tK2) tA
-- scross# :: [p : Proc]. [kR kO : Rate]. [a b : Data]
-- . Series p kR a
-- -> RateVec kO b
-- -> Series p (kR * kO) (a,b)
OpSeriesCross
-> Just $ tForalls [kProc, kRate, kRate, kData, kData] $
\[tP, tKR, tKO, tA, tB]
-> tSeries tP tKR tA
`tFun` tRateVec tKO tB
`tFun` tSeries tP (tRateCross tKR tKO) (tTuple2 tA tB)
-- generate# :: [p : Proc]. [k : Rate]. [a : Data]
-- . (Nat# -> a) -> Series p k a
OpSeriesGenerate
-> Just $ tForalls [kProc, kRate, kData] $ \[tP, tK, tA]
-> (tNat `tFun` tA)
`tFun` tSeries tP tK tA
-- Reductions -------------------------------
-- reduce# :: [p : Proc]. [k : Rate]. [a : Data]
-- . Ref a -> (a -> a -> a) -> a -> Series p k a -> Process p k
OpSeriesReduce
-> Just $ tForalls [kProc, kRate, kData] $ \[tP, tK, tA]
-> tRef tA
`tFun` (tA `tFun` tA `tFun` tA)
`tFun` tA
`tFun` tSeries tP tK tA
`tFun` tProcess tP tK
-- folds# :: [p : Proc]. [k1 k2 : Rate]. [a : Data]
-- . Segd# k1 k2 -> Series p k1 a -> Series k2 b
OpSeriesFolds
-> Just $ tForalls [kProc, kRate, kRate, kData] $ \[tP, tK1, tK2, tA]
-> tSegd tK1 tK2
`tFun` tSeries tP tK1 tA
`tFun` tSeries tP tK2 tA
-- Store operators ---------------------------
-- scatter# :: [p : Proc]. [k : Rate]. [a : Data]
-- . Vector a -> Series p k Nat# -> Series p k a -> Process p k
OpSeriesScatter
-> Just $ tForalls [kProc, kRate, kData] $ \[tP, tK, tA]
-> tVector tA
`tFun` tSeries tP tK tNat
`tFun` tSeries tP tK tA
`tFun` tProcess tP tK
-- gather# :: [p : Proc]. [k1 k2 : Rate]. [a : Data]
-- . RateVec k1 a -> Series p k2 Nat# -> Series p k2 a
OpSeriesGather
-> Just $ tForalls [kProc, kRate, kRate, kData] $ \[tP, tK1, tK2, tA]
-> tRateVec tK1 tA
`tFun` tSeries tP tK2 tNat
`tFun` tSeries tP tK2 tA
-- fill# :: [p : Proc]. [k : Rate]. [a : Data]. Vector a -> Series p k a -> Process p k
OpSeriesFill
-> Just $ tForalls [kProc, kRate, kData] $ \[tP, tK, tA]
-> tVector tA
`tFun` tSeries tP tK tA
`tFun` tProcess tP tK
-- Resizing -----------------------
-- presize# :: [p : Proc]. [j k : Rate]
-- . Resize p j k
-- -> Process p j
-- -> Process p k
OpSeriesResizeProc
-> Just $ tForalls [kProc, kRate, kRate] $
\[tP, tJ, tK]
-> tResize tP tJ tK
`tFun` tProcess tP tJ
`tFun` tProcess tP tK
-- rid# :: [p : Proc]. [k : Rate]
-- . Resize p k k
OpSeriesResizeId
-> Just $ tForalls [kProc, kRate] $
\[tP, tK]
-> tResize tP tK tK
-- rappl# :: [p : Proc]. [k l : Rate]
-- . Resize p k (Append k l)
OpSeriesResizeAppL
-> Just $ tForalls [kProc, kRate, kRate] $
\[tP, tK, tL]
-> tResize tP tK (tRateAppend tK tL)
-- rappr# :: [p : Proc]. [k l : Rate]
-- . Resize p l (Append k l)
OpSeriesResizeAppR
-> Just $ tForalls [kProc, kRate, kRate] $
\[tP, tK, tL]
-> tResize tP tL (tRateAppend tK tL)
-- rapp# :: [p : Proc]. [k k' l l' : Rate]
-- . Resize k k'
-- -> Resize l l'
-- -> Resize (Append k l) (Append k' l')
OpSeriesResizeApp
-> Just $ tForalls [kProc, kRate, kRate, kRate, kRate] $
\[tP, tK, tK', tL, tL']
-> tResize tP tK tK'
`tFun` tResize tP tL tL'
`tFun` tResize tP (tRateAppend tK tL) (tRateAppend tK' tL')
-- rsel1# :: [p : Proc]. [j k l : Rate]
-- . Sel1 p k l
-- -> Resize p j l
-- -> Resize p j k
OpSeriesResizeSel1
-> Just $ tForalls [kProc, kRate, kRate, kRate] $
\[tP, tJ, tK, tL]
-> tSel1 tP tK tL
`tFun` tResize tP tJ tL
`tFun` tResize tP tJ tK
-- rsegd# :: [p : Proc]. [j k l : Rate]
-- . Segd k l
-- -> Resize p j l
-- -> Resize p j k
OpSeriesResizeSegd
-> Just $ tForalls [kProc, kRate, kRate, kRate] $
\[tP, tJ, tK, tL]
-> tSegd tK tL
`tFun` tResize tP tJ tL
`tFun` tResize tP tJ tK
-- rcross# :: [p : Proc]. [j k l : Rate]
-- . Resize p j (Cross k l)
-- -> Resize p j k
OpSeriesResizeCross
-> Just $ tForalls [kProc, kRate, kRate, kRate] $
\[tP, tJ, tK, tL]
-> tResize tP tJ (tRateCross tK tL)
`tFun` tResize tP tJ tK
_ -> Nothing
-- Compounds ------------------------------------------------------------------
xSeriesOfRateVec :: Type Name -> Type Name -> Type Name -> Exp () Name -> Exp () Name
xSeriesOfRateVec tP tK tA xV
= xApps (xVarOpSeries OpSeriesSeriesOfRateVec)
[XType tP, XType tK, XType tA, xV]
-- Utils -----------------------------------------------------------------------
xVarOpSeries :: OpSeries -> Exp () Name
xVarOpSeries op
= XVar (UPrim (NameOpSeries op) (typeOpSeries op))