module DDC.Core.Flow.Prim.OpFlow
( readOpFlow
, typeOpFlow
, xRateOfSeries
, xNatOfRateNat)
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.LiftT
import DDC.Core.Compounds.Simple
import DDC.Core.Exp.Simple
import DDC.Base.Pretty
import Control.DeepSeq
import Data.List
import Data.Char
instance NFData OpFlow
instance Pretty OpFlow where
ppr pf
= case pf of
OpFlowVectorOfSeries -> text "vectorOfSeries" <> text "#"
OpFlowRateOfSeries -> text "rateOfSeries" <> text "#"
OpFlowNatOfRateNat -> text "natOfRateNat" <> text "#"
OpFlowMkSel 1 -> text "mkSel" <> text "#"
OpFlowMkSel n -> text "mkSel" <> int n <> text "#"
OpFlowMap 1 -> text "map" <> text "#"
OpFlowMap i -> text "map" <> int i <> text "#"
OpFlowRep -> text "rep" <> text "#"
OpFlowReps -> text "reps" <> text "#"
OpFlowFold -> text "fold" <> text "#"
OpFlowFoldIndex -> text "foldIndex" <> text "#"
OpFlowFolds -> text "folds" <> text "#"
OpFlowUnfold -> text "unfold" <> text "#"
OpFlowUnfolds -> text "unfolds" <> text "#"
OpFlowSplit i -> text "split" <> int i <> text "#"
OpFlowCombine i -> text "combine" <> int i <> text "#"
OpFlowPack -> text "pack" <> text "#"
readOpFlow :: String -> Maybe OpFlow
readOpFlow str
| Just rest <- stripPrefix "mkSel" str
, (ds, "#") <- span isDigit rest
, not $ null ds
, arity <- read ds
, arity == 1
= Just $ OpFlowMkSel arity
| Just rest <- stripPrefix "map" str
, (ds, "#") <- span isDigit rest
, not $ null ds
, arity <- read ds
= Just $ OpFlowMap arity
| Just rest <- stripPrefix "split" str
, (ds, "#") <- span isDigit rest
, not $ null ds
, arity <- read ds
= Just $ OpFlowSplit arity
| Just rest <- stripPrefix "combine" str
, (ds, "#") <- span isDigit rest
, not $ null ds
, arity <- read ds
= Just $ OpFlowCombine arity
| otherwise
= case str of
"vectorOfSeries#" -> Just $ OpFlowVectorOfSeries
"rateOfSeries#" -> Just $ OpFlowRateOfSeries
"natOfRateNat#" -> Just $ OpFlowNatOfRateNat
"mkSel#" -> Just $ OpFlowMkSel 1
"map#" -> Just $ OpFlowMap 1
"rep#" -> Just $ OpFlowRep
"reps#" -> Just $ OpFlowReps
"fold#" -> Just $ OpFlowFold
"foldIndex#" -> Just $ OpFlowFoldIndex
"folds#" -> Just $ OpFlowFolds
"unfold#" -> Just $ OpFlowUnfold
"unfolds#" -> Just $ OpFlowUnfolds
"pack#" -> Just $ OpFlowPack
_ -> Nothing
typeOpFlow :: OpFlow -> Type Name
typeOpFlow op
= case takeTypeOpFlow op of
Just t -> t
Nothing -> error $ "ddc-core-flow.typeOpFlow: invalid op " ++ show op
takeTypeOpFlow :: OpFlow -> Maybe (Type Name)
takeTypeOpFlow op
= case op of
OpFlowVectorOfSeries
-> Just $ tForalls [kRate, kData] $ \[tK, tA]
-> tSeries tK tA `tFun` tVector tA
OpFlowRateOfSeries
-> Just $ tForalls [kRate, kData] $ \[tK, tA]
-> tSeries tK tA `tFun` tRateNat tK
OpFlowNatOfRateNat
-> Just $ tForall kRate $ \tK
-> tRateNat tK `tFun` tNat
OpFlowMkSel 1
-> Just $ tForalls [kRate, kData] $ \[tK1, tA]
-> tSeries tK1 tBool
`tFun` (tForall kRate $ \tK2
-> tSel1 (liftT 1 tK1) tK2 `tFun` (liftT 1 tA))
`tFun` tA
OpFlowMap 1
-> Just $ tForalls [kRate, kData, kData] $ \[tK, tA, tB]
-> (tA `tFun` tB)
`tFun` tSeries tK tA
`tFun` tSeries tK tB
OpFlowMap n
| n >= 2
, Just tWork <- tFunOfList
[ TVar (UIx i)
| i <- reverse [0..n] ]
, Just tBody <- tFunOfList
(tWork : [tSeries (TVar (UIx (n + 1))) (TVar (UIx i))
| i <- reverse [0..n] ])
-> Just $ foldr TForall tBody
[ BAnon k | k <- kRate : replicate (n + 1) kData ]
OpFlowRep
-> Just $ tForalls [kData, kRate] $ \[tA, tR]
-> tA `tFun` tSeries tR tA
OpFlowReps
-> Just $ tForalls [kRate, kRate, kData] $ \[tK1, tK2, tA]
-> tSegd tK1 tK2
`tFun` tSeries tK1 tA
`tFun` tSeries tK2 tA
OpFlowFold
-> Just $ tForalls [kRate, kData, kData] $ \[tK, tA, tB]
-> (tA `tFun` tB `tFun` tA)
`tFun` tA
`tFun` tSeries tK tB
`tFun` tA
OpFlowFoldIndex
-> Just $ tForalls [kRate, kData, kData] $ \[tK, tA, tB]
-> (tInt `tFun` tA `tFun` tB `tFun` tA)
`tFun` tA
`tFun` tSeries tK tB
`tFun` tA
OpFlowFolds
-> Just $ tForalls [kRate, kRate, kData, kData] $ \[tK1, tK2, tA, tB]
-> tSegd tK1 tK2
`tFun` (tInt `tFun` tA `tFun` tB `tFun` tA)
`tFun` tSeries tK1 tA
`tFun` tSeries tK2 tB
`tFun` tSeries tK1 tA
OpFlowPack
-> Just $ tForalls [kRate, kRate, kData] $ \[tK1, tK2, tA]
-> tSel1 tK1 tK2
`tFun` tSeries tK1 tA
`tFun` tSeries tK2 tA
_ -> Nothing
xRateOfSeries :: Type Name -> Type Name -> Exp () Name -> Exp () Name
xRateOfSeries tK tA xS
= xApps (xVarOpFlow OpFlowRateOfSeries)
[XType tK, XType tA, xS]
xNatOfRateNat :: Type Name -> Exp () Name -> Exp () Name
xNatOfRateNat tK xR
= xApps (xVarOpFlow OpFlowNatOfRateNat)
[XType tK, xR]
xVarOpFlow :: OpFlow -> Exp () Name
xVarOpFlow op
= XVar (UPrim (NameOpFlow op) (typeOpFlow op))