module DDC.Core.Flow.Transform.Thread
( threadConfig
, wrapResultType
, wrapResultExp
, unwrapResult
, threadType)
where
import DDC.Core.Flow.Compounds
import DDC.Core.Flow.Profile
import DDC.Core.Flow.Prim
import DDC.Core.Compounds as C
import DDC.Core.Exp
import DDC.Core.Transform.Thread
import DDC.Core.Transform.Reannotate
import DDC.Core.Check (AnTEC (..))
import qualified DDC.Core.Check as Check
threadConfig :: Config () Name
threadConfig
= Config
{ configCheckConfig = Check.configOfProfile profile
, configTokenType = tWorld
, configVoidType = tUnit
, configWrapResultType = wrapResultType
, configWrapResultExp = wrapResultExp
, configThreadMe = threadType
, configThreadPat = unwrapResult }
wrapResultType :: Type Name -> Type Name
wrapResultType tt
| Just (TyConBound u _, tsArgs) <- takeTyConApps tt
, UPrim n _ <- u
, NameTyConFlow (TyConFlowTuple _) <- n
= tTupleN (tWorld : tsArgs)
| otherwise
= tTuple2 tWorld tt
wrapResultExp
:: Exp (AnTEC () Name) Name
-> Exp (AnTEC () Name) Name
-> Exp () Name
wrapResultExp xWorld xResult
| aResult <- annotOfExp xResult
, annotType aResult == tUnit
= reannotate annotTail xWorld
| aWorld <- annotOfExp xWorld
, aResult <- annotOfExp xResult
= let tWorld' = annotType aWorld
tResult = annotType aResult
xWorld' = reannotate annotTail xWorld
xResult' = reannotate annotTail xResult
in case C.takeXConApps xResult' of
Just (dc, xa)
| DaConPrim (NameDaConFlow (DaConFlowTuple n)) _ <- dc
, x <- length xa
, x >= 2
-> let (b, a) = splitAt (x `quot` 2) xa
in C.xApps () (XCon () (dcTupleN $ n + 1))
$ XType (annotTail aWorld) tWorld' : b
++ xWorld' : a
_ -> C.xApps () (XCon () (dcTupleN 2))
[ XType (annotTail aWorld) tWorld'
, XType (annotTail aResult) tResult
, xWorld'
, xResult' ]
| otherwise
= error "ddc-core-flow: wrapResultExp can't get type annotations"
unwrapResult :: Name -> Maybe (Bind Name -> [Bind Name] -> Pat Name)
unwrapResult _
= Just unwrap
where unwrap bWorld bsResult
| [bResult] <- bsResult
, typeOfBind bResult == tUnit
= PData dcTuple1 [bWorld]
| otherwise
= PData (dcTupleN (length (bWorld : bsResult)))
(bWorld : bsResult)
threadType :: Name -> Type Name -> Maybe (Type Name)
threadType n _
= case n of
NameOpStore OpStoreNew
-> Just $ tForall kData
$ \tA -> tA
`tFun` tWorld `tFun` (tTuple2 tWorld (tRef tA))
NameOpStore OpStoreRead
-> Just $ tForall kData
$ \tA -> tRef tA
`tFun` tWorld `tFun` (tTuple2 tWorld (tRef tA))
NameOpStore OpStoreWrite
-> Just $ tForall kData
$ \tA -> tRef tA `tFun` tA
`tFun` tWorld `tFun` tWorld
NameOpStore OpStoreNewVector
-> Just $ tForall kData
$ \tA -> tNat
`tFun` tWorld `tFun` (tTuple2 tWorld (tVector tA))
NameOpStore OpStoreNewVectorN
-> Just $ tForalls [kData, kRate]
$ \[tA, tK]
-> tRateNat tK
`tFun` tWorld `tFun` (tTuple2 tWorld (tVector tA))
NameOpStore (OpStoreReadVector _)
-> Just $ tForall kData
$ \tA -> tA `tFun` tVector tA `tFun` tNat
`tFun` tWorld `tFun` (tTuple2 tWorld tA)
NameOpStore (OpStoreWriteVector _)
-> Just $ tForall kData
$ \tA -> tA `tFun` tVector tA `tFun` tNat `tFun` tA
`tFun` tWorld `tFun` tWorld
NameOpStore OpStoreTruncVector
-> Just $ tForall kData
$ \tA -> tNat `tFun` tVector tA
`tFun` tWorld `tFun` tWorld
NameOpConcrete (OpConcreteNext 1)
-> Just $ tForalls [kRate, kData]
$ \[tK, tA] -> tSeries tK tA `tFun` tInt
`tFun` tWorld `tFun` (tTuple2 tWorld tA)
NameOpConcrete (OpConcreteNext c)
| c >= 2
-> Just $ tForalls [kRate, kData]
$ \[tK, tA] -> tSeries (tDown c tK) tA `tFun` tInt
`tFun` tWorld `tFun` (tTuple2 tWorld (tVec c tA))
NameOpControl OpControlLoopN
-> Just $ tForalls [kRate]
$ \[tK] -> tRateNat tK
`tFun` (tNat `tFun` tWorld `tFun` tWorld)
`tFun` tWorld `tFun` tWorld
NameOpControl OpControlGuard
-> Just $ tRef tNat
`tFun` tBool
`tFun` (tNat `tFun` tWorld `tFun` tWorld)
`tFun` tWorld `tFun` tWorld
NameOpControl (OpControlSplit c)
-> Just $ tForall kRate
$ \tK -> tRateNat tK
`tFun` (tRateNat (tDown c tK) `tFun` tWorld `tFun` tWorld)
`tFun` (tRateNat (tTail c tK) `tFun` tWorld `tFun` tWorld)
`tFun` tWorld `tFun` tWorld
_ -> Nothing