Prompt.hs

Prompt.hs

{-# LANGuAGE NamedFieldPuns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE FlexibleContexts #-}
module Language.Plutus.Contract.NewContract where

import Control.Applicative
import Data.Map (Map)
import Data.Bifunctor
import qualified Data.Map as Map

import Control.Monad.Freer
import Control.Monad.Freer.Trace
import Control.Monad.Freer.Coroutine
import Control.Monad.Freer.NonDet
import Control.Monad.Freer.State

newtype RequestID = RequestID Int
    deriving (Eq, Ord, Show)

nextID :: RequestID -> RequestID
nextID (RequestID i) = RequestID (succ i)

newtype IterationID = IterationID Int
    deriving (Eq, Ord, Show)

nextIteration :: IterationID -> IterationID
nextIteration (IterationID i) = IterationID (succ i)

data Request =
    Request
        { rqID :: RequestID
        , itID :: IterationID
        , rqRequest :: String
        } deriving (Eq, Ord, Show)

data RequestState =
    RequestState
        { rsOpenRequests :: [Request]
        , rsRequestID    :: RequestID
        } deriving (Eq, Ord, Show)

pruneRequests ::
    RequestState
    -> RequestState
pruneRequests r@RequestState{rsOpenRequests=[]} = r
pruneRequests r@RequestState{rsOpenRequests} =
    let maxIteration = maximum (itID <$> rsOpenRequests)
    in r{rsOpenRequests = filter ((==) maxIteration . itID) rsOpenRequests}

request ::
    ( Member (State RequestState) effs
    , Member (State IterationID) effs
    )
    => String
    -> Eff effs (IterationID, RequestID)
request s = do
    RequestState{rsOpenRequests,rsRequestID} <- get
    iid <- get @IterationID
    let niid = nextIteration iid
        nid  = nextID rsRequestID
    put $ RequestState
            { rsOpenRequests = Request{rqRequest=s,rqID=nid,itID=niid} : rsOpenRequests
            , rsRequestID = nid
            }
    put niid
    pure (niid, nid)

clearRequests :: Member (State RequestState) effs => Eff effs ()
clearRequests = modify (\rq -> rq{rsOpenRequests = [], rsRequestID=RequestID 0 })

askInfo :: Member (Yield String Int) r => String -> Eff r Int
askInfo s = yield s id

askInfoNDet :: (Member NonDet effs, Member (Yield String Int) effs) => String -> Eff effs Int
askInfoNDet s = empty

runRequests ::
    Map IterationID (Map RequestID Int)
    -> Eff '[Yield String Int, State IterationID, NonDet, State RequestState, Trace] a
    -> IO (Maybe a, RequestState)
runRequests mp e = fmap (second pruneRequests) . runTrace . runState (RequestState [] (RequestID 0)) $ makeChoiceA @Maybe $ evalState (IterationID 0) $ (loop =<< runC e) where
    loop :: Status '[State IterationID, NonDet, State RequestState, Trace] String Int a -> Eff '[State IterationID, NonDet, State RequestState, Trace] a
    loop (Continue a k) = do
        rq@(iid,nid) <- request a
        case Map.lookup iid mp >>= Map.lookup nid of
            Nothing -> empty
            Just v  -> trace (show rq <> a <> " <- " <> show v) >> clearRequests >> k v >>= loop
    loop (Done a)       = trace "Done" >> pure a

runRequests' = runRequests (Map.fromList l)
    where
        l = [
              (IterationID 1, Map.singleton (RequestID 1) 0)
            , (IterationID 2, Map.singleton (RequestID 2) 20)
            , (IterationID 3, Map.singleton (RequestID 1) 1)
            ]
-- >runRequests' (((+) <$> (askInfo "b" <|> askInfo "f") <*> (askInfo "g" <|> askInfo "b")) >>= askInfo . show)
-- (IterationID 1,RequestID 1) -> 10
-- Missing request: (IterationID 2,RequestID 1)
-- (IterationID 2,RequestID 2) -> 20
-- (IterationID 3,RequestID 1) -> 5
-- Done
-- (IterationID 1,RequestID 1) -> 10
-- Missing request: (IterationID 2,RequestID 1)
-- (IterationID 2,RequestID 2) -> 20
-- (IterationID 3,RequestID 1) -> 5
-- Done
-- (Just 5,RequestState {rsOpenRequests = [], rsRequestID = RequestID 0})