module DDC.Core.Flow.Prim.OpSeries
( readOpSeries
, typeOpSeries
, 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.Transform.BoundT
import DDC.Core.Exp.Simple.Compounds
import DDC.Core.Exp.Simple.Exp
import DDC.Base.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 "#"
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
typeOpSeries :: OpSeries -> Type Name
typeOpSeries op
= case takeTypeOpSeries op of
Just t -> t
Nothing -> error $ "ddc-core-flow.typeOpSeries: invalid op " ++ show op
takeTypeOpSeries :: OpSeries -> Maybe (Type Name)
takeTypeOpSeries op
= case op of
OpSeriesRep
-> Just $ tForalls [kProc, kRate, kData] $ \[tP, tR, tA]
-> tA `tFun` tSeries tP tR tA
OpSeriesReps
-> Just $ tForalls [kProc, kRate, kRate, kData] $ \[tP, tK1, tK2, tA]
-> tSegd tK1 tK2 `tFun` tSeries tP tK1 tA `tFun` tSeries tP tK2 tA
OpSeriesIndices
-> Just $ tForalls [kProc, kRate, kRate] $ \[tP, tK1, tK2]
-> tSegd tK1 tK2 `tFun` tSeries tP tK2 tNat
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
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 ]
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
OpSeriesJoin
-> Just $ tForalls [kProc, kRate] $
\[tP, tK]
-> tProcess tP tK
`tFun` tProcess tP tK
`tFun` tProcess tP tK
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
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
OpSeriesRunProcess
-> Just $ tForalls [kRate] $ \[tK]
-> (tForall kProc $ \tP
-> tUnit `tFun` tProcess tP (liftT 1 tK))
`tFun` tUnit
OpSeriesRunProcessUnit
-> Just $ tForalls [kRate] $ \[_]
-> (tForall kProc $ \_
-> tUnit `tFun` tUnit)
`tFun` tUnit
OpSeriesRateVecsOfVectors 0
-> Just $ tForall kData $ \tA
-> tNat
`tFun` (tForall kRate $ \_ -> liftT 1 tA)
`tFun` tA
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 ]
OpSeriesSeriesOfRateVec
-> Just $ tForalls [kProc, kRate, kData] $ \[tP, tK, tA]
-> tRateVec tK tA `tFun` tSeries tP tK tA
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
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)
OpSeriesGenerate
-> Just $ tForalls [kProc, kRate, kData] $ \[tP, tK, tA]
-> (tNat `tFun` tA)
`tFun` tSeries tP tK tA
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
OpSeriesFolds
-> Just $ tForalls [kProc, kRate, kRate, kData] $ \[tP, tK1, tK2, tA]
-> tSegd tK1 tK2
`tFun` tSeries tP tK1 tA
`tFun` tSeries tP tK2 tA
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
OpSeriesGather
-> Just $ tForalls [kProc, kRate, kRate, kData] $ \[tP, tK1, tK2, tA]
-> tRateVec tK1 tA
`tFun` tSeries tP tK2 tNat
`tFun` tSeries tP tK2 tA
OpSeriesFill
-> Just $ tForalls [kProc, kRate, kData] $ \[tP, tK, tA]
-> tVector tA
`tFun` tSeries tP tK tA
`tFun` tProcess tP tK
OpSeriesResizeProc
-> Just $ tForalls [kProc, kRate, kRate] $
\[tP, tJ, tK]
-> tResize tP tJ tK
`tFun` tProcess tP tJ
`tFun` tProcess tP tK
OpSeriesResizeId
-> Just $ tForalls [kProc, kRate] $
\[tP, tK]
-> tResize tP tK tK
OpSeriesResizeAppL
-> Just $ tForalls [kProc, kRate, kRate] $
\[tP, tK, tL]
-> tResize tP tK (tRateAppend tK tL)
OpSeriesResizeAppR
-> Just $ tForalls [kProc, kRate, kRate] $
\[tP, tK, tL]
-> tResize tP tL (tRateAppend tK tL)
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')
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
OpSeriesResizeSegd
-> Just $ tForalls [kProc, kRate, kRate, kRate] $
\[tP, tJ, tK, tL]
-> tSegd tK tL
`tFun` tResize tP tJ tL
`tFun` tResize tP tJ tK
OpSeriesResizeCross
-> Just $ tForalls [kProc, kRate, kRate, kRate] $
\[tP, tJ, tK, tL]
-> tResize tP tJ (tRateCross tK tL)
`tFun` tResize tP tJ tK
_ -> Nothing
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]
xVarOpSeries :: OpSeries -> Exp () Name
xVarOpSeries op
= XVar (UPrim (NameOpSeries op) (typeOpSeries op))