module Rasa.Internal.BufAction
( BufAction(..)
, getText
, setText
, getRange
, setRange
, liftState
, liftAction
, runBufAction
) where
import Rasa.Internal.Buffer
import Rasa.Internal.Editor
import Rasa.Internal.Action
import Rasa.Internal.Range
import Rasa.Internal.Listeners
import Rasa.Internal.Events
import Rasa.Internal.Extensions
import Control.Lens
import Control.Monad.Free
import Control.Monad.State
import qualified Yi.Rope as Y
data BufActionState = BufActionState
{ _buffer' :: Buffer
, _actionState :: ActionState
}
makeLenses ''BufActionState
instance HasBufExts BufActionState where
bufExts = buffer'.bufExts
data BufActionF state next =
GetText (Y.YiString -> next)
| SetText Y.YiString next
| SetRange CrdRange Y.YiString next
| LiftState (state -> (next, state))
| LiftIO (IO next)
deriving (Functor)
liftBufAction :: BufActionF BufActionState a -> BufAction a
liftBufAction = BufAction . liftF
getText :: BufAction Y.YiString
getText = liftBufAction $ GetText id
setText :: Y.YiString -> BufAction ()
setText txt = liftBufAction $ SetText txt ()
getRange :: CrdRange -> BufAction Y.YiString
getRange rng = view (range rng) <$> getText
setRange :: CrdRange -> Y.YiString -> BufAction ()
setRange rng txt = liftBufAction $ SetRange rng txt ()
liftState :: (BufActionState -> (a, BufActionState)) -> BufAction a
liftState = liftBufAction . LiftState
liftFIO :: IO r -> BufAction r
liftFIO = liftBufAction . LiftIO
newtype BufAction a = BufAction
{ getBufAction :: Free (BufActionF BufActionState) a
} deriving (Functor, Applicative, Monad)
instance (MonadState BufActionState) BufAction where
state = liftState
instance MonadIO BufAction where
liftIO = liftFIO
liftAction :: Action r -> BufAction r
liftAction action = do
actState <- use actionState
(res, endState) <- liftIO $ runAction actState action
actionState .= endState
return res
bufAt :: BufRef -> Traversal' ActionState Buffer
bufAt (BufRef bufInd) = buffers.at bufInd._Just
runBufAction :: BufAction a -> BufRef -> Action (Maybe a)
runBufAction (BufAction bufActF) = flip bufActionInterpreter bufActF
bufActionInterpreter :: BufRef -> Free (BufActionF BufActionState) r -> Action (Maybe r)
bufActionInterpreter bRef (Free bufActionF) =
case bufActionF of
(GetText nextF) -> do
actState <- get
case actState^? bufAt bRef of
Nothing -> return Nothing
Just buf -> bufActionInterpreter bRef (nextF (buf^.text))
(SetText newText next) -> do
bufAt bRef.text .= newText
bufActionInterpreter bRef next
(SetRange rng newText next) -> do
bufAt bRef.text.range rng .= newText
dispatchEvent $ BufTextChanged rng newText
bufActionInterpreter bRef next
(LiftState stateFunc) -> do
mBuf <- preuse (bufAt bRef)
case mBuf of
Nothing -> return Nothing
Just buf -> do
actState <- get
let (next, BufActionState newBuf newActState) = stateFunc (BufActionState buf actState)
put newActState
bufAt bRef .= newBuf
bufActionInterpreter bRef next
(LiftIO ioNext) ->
liftIO ioNext >>= bufActionInterpreter bRef
bufActionInterpreter _ (Pure res) = return $ Just res