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
| Just aResult <- takeAnnotOfExp xResult
, annotType aResult == tUnit
= reannotate annotTail xWorld
| Just aWorld <- takeAnnotOfExp xWorld
, Just aResult <- takeAnnotOfExp xResult
= let tWorld' = annotType aWorld
tResult = annotType aResult
xWorld' = reannotate annotTail xWorld
xResult' = reannotate annotTail xResult
in
case C.takeXConApps xResult' of
Just (dc, [xT1, xT2
, x1, x2])
| dc == dcTupleN 2
-> C.xApps () (XCon () (dcTupleN 3))
[ XType tWorld', xT1, xT2
, xWorld', x1, x2]
Just (dc, [xT1, xT2, xT3
, x1, x2, x3])
| dc == dcTupleN 3
-> C.xApps () (XCon () (dcTupleN 4))
[ XType tWorld', xT1, xT2, xT3
, xWorld', x1, x2, x3]
Just (dc, [xT1, xT2, xT3, xT4
, x1, x2, x3, x4])
| dc == dcTupleN 4
-> C.xApps () (XCon () (dcTupleN 5))
[ XType tWorld', xT1, xT2, xT3, xT4
, xWorld', x1, x2, x3, x4]
_ -> C.xApps () (XCon () (dcTupleN 2))
[ XType tWorld'
, XType 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 OpStoreSliceVector
-> Just $ tForall kData
$ \tA -> tNat `tFun` tVector tA
`tFun` tWorld `tFun` (tTuple2 tWorld (tVector tA))
NameOpStore OpStoreNext
-> Just $ tForalls [kRate, kData]
$ \[tK, tA] -> tSeries tK tA `tFun` tInt
`tFun` tWorld `tFun` (tTuple2 tWorld tA)
NameOpLoop OpLoopLoopN
-> Just $ tForalls [kRate]
$ \[tK] -> tRateNat tK
`tFun` (tNat `tFun` tWorld `tFun` tWorld)
`tFun` tWorld `tFun` tWorld
NameOpLoop OpLoopGuard
-> Just $ tRef tNat
`tFun` tBool
`tFun` (tNat `tFun` tWorld `tFun` tWorld)
`tFun` tWorld `tFun` tWorld
_ -> Nothing