diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -22,8 +22,6 @@ - [rasa-ext-cursors](https://hackage.haskell.org/package/rasa-ext-cursors) - [rasa-ext-files](https://hackage.haskell.org/package/rasa-ext-files) - [rasa-ext-logger](https://hackage.haskell.org/package/rasa-ext-logger) -- [rasa-ext-status-bar](https://hackage.haskell.org/package/rasa-ext-status-bar) -- [rasa-ext-style](https://hackage.haskell.org/package/rasa-ext-style) What people are saying ---------------------- @@ -34,48 +32,6 @@ > You should go outside one of these days. - Mother -Installation ------------- - -At the moment you must build Rasa from source; - -1. Install [stack](http://seanhess.github.io/2015/08/04/practical-haskell-getting-started.html) -2. Clone this repo and `cd` into the directory -3. Run `stack build && stack exec rasa` (you may want to alias this to `rasa`) - -### Troubleshooting - -- You may need to install icu4c (`brew install icu4c`), it's a dependency of the rope library rasa uses. -- On linux, when the error message `Missing C libraries: icuuc, icui18n, icudata` appears, install `libicu-dev` (e.g. with `sudo apt install libicu-dev`). -- You'll need to point to the icu4c lib in your stack.yaml wherever it's stored on your system. If you install - using brew on your Mac, then you can add the following to your stack.yaml: - -```yaml -extra-lib-dirs: -- /usr/local/opt/icu4c/lib -extra-include-dirs: -- /usr/local/opt/icu4c/include -``` - -- Depending on which LTS you're on, you'll likely also have to add each rasa package you use to your stack.yaml as - extra-deps, here's an example: - -```yaml -# in stack.yaml -extra-deps: -- rasa-0.1.0.0 -- rasa-ext-cursors-0.1.0.0 -- rasa-ext-logger-0.1.0.0 -- rasa-ext-status-bar-0.1.0.0 -- rasa-ext-vim-0.1.0.0 -- text-lens-0.1.0.0 -- rasa-ext-files-0.1.0.0 -- rasa-ext-cmd-0.1.0.0 -- rasa-ext-slate-0.1.0.0 -- rasa-ext-style-0.1.0.0 -- vty-5.14 -``` - Getting started --------------- @@ -174,11 +130,67 @@ - `stack test rasa` + +Installation +------------ + +At the moment you must build Rasa from source; + +To provide reproducible builds, Rasa uses Stack & Nix. + +1. Install [stack](http://seanhess.github.io/2015/08/04/practical-haskell-getting-started.html) +2. Install [nix](https://nixos.org/nix/) +3. Clone this repo and `cd` into the directory +4. Run `stack build && stack exec rasa` (you may want to alias this to `rasa`) + +Installation without nix (not-recommended) +------------------------------------------ + +1. Install [stack](http://seanhess.github.io/2015/08/04/practical-haskell-getting-started.html) +2. Clone this repo and `cd` into the directory +3. Run `stack build --no-nix && stack exec rasa --no-nix` (you may want to alias this to `rasa`) + +### Troubleshooting + +If you have issues with nix; you may try running rasa without it with `stack build --no-nix && stack exec rasa`; +You'll likely have to consider the following: + +- You may need to install icu4c (`brew install icu4c`), it's a dependency of the rope library rasa uses. +- On linux, when the error message `Missing C libraries: icuuc, icui18n, icudata` appears, install `libicu-dev` (e.g. with `sudo apt install libicu-dev`). +- You'll need to point to the icu4c lib in your stack.yaml wherever it's stored on your system. If you install + using brew on your Mac, then you can add the following to your stack.yaml: + +```yaml +extra-lib-dirs: +- /usr/local/opt/icu4c/lib +extra-include-dirs: +- /usr/local/opt/icu4c/include +``` + +- Depending on which LTS you're on, you'll likely also have to add each rasa package you use to your stack.yaml as + extra-deps, here's an example: + +```yaml +# in stack.yaml +extra-deps: +- rasa-0.1.0.0 +- rasa-ext-cursors-0.1.0.0 +- rasa-ext-logger-0.1.0.0 +- rasa-ext-vim-0.1.0.0 +- text-lens-0.1.0.0 +- rasa-ext-files-0.1.0.0 +- rasa-ext-cmd-0.1.0.0 +- rasa-ext-slate-0.1.0.0 +- vty-5.14 +``` + Contributing ------------ Things are moving quickly, but I'd love a hand! You can get a rough idea of where you can help out at the [Roadmap](https://github.com/ChrisPenner/rasa/issues/2), feel free to leave a -comment there asking any questions, I'm often free to chat, join our [gitter -here](https://gitter.im/rasa-editor/Lobby)! +comment there asking any questions. + +Chatting about features is a key part of Rasa's development; come join us in +the [Chat Room](https://gitter.im/rasa-editor/Lobby)! diff --git a/rasa.cabal b/rasa.cabal --- a/rasa.cabal +++ b/rasa.cabal @@ -1,5 +1,5 @@ name: rasa -version: 0.1.9 +version: 0.1.10 cabal-version: >=1.10 build-type: Simple license: GPL-3 @@ -58,21 +58,27 @@ exposed-modules: Rasa Rasa.Ext + Rasa.Testing + Rasa.Internal.ActionMonads Rasa.Internal.Action Rasa.Internal.Actions - Rasa.Internal.Async Rasa.Internal.BufAction + Rasa.Internal.BufActions Rasa.Internal.Buffer Rasa.Internal.Editor Rasa.Internal.Events Rasa.Internal.Extensions + Rasa.Internal.Interpreters Rasa.Internal.Listeners Rasa.Internal.Range + Rasa.Internal.Styles Rasa.Internal.Text + Rasa.Internal.Utility build-depends: base >=4.8 && <5, async >=2.1.1 && <2.2, bifunctors >=5.4.1 && <5.5, + profunctors ==5.2.*, containers >=0.5.7.1 && <0.6, data-default >=0.7.1.1 && <0.8, free >=4.12.4 && <4.13, @@ -84,7 +90,8 @@ yi-rope >=0.7.0.2 && <0.8, pipes >=4.1.9 && <4.2, pipes-concurrency >=2.0.6 && <2.1, - pipes-parse >=3.0.7 && <3.1 + pipes-parse >=3.0.7 && <3.1, + hspec >=2.2.4 && <2.3 default-language: Haskell2010 hs-source-dirs: src ghc-options: -Wall @@ -94,7 +101,7 @@ main-is: Spec.hs build-depends: base >=4.9.0.0 && <4.10, - rasa >=0.1.9 && <0.2, + rasa >=0.1.10 && <0.2, hspec >=2.2.4 && <2.3, lens ==4.14.*, yi-rope >=0.7.0.2 && <0.8, @@ -111,6 +118,7 @@ Rasa.Internal.ActionsSpec Rasa.Internal.AsyncSpec Rasa.Internal.BufActionSpec + Rasa.Internal.BufActionsSpec Rasa.Internal.BufferSpec Rasa.Internal.EditorSpec Rasa.Internal.EventsSpec @@ -118,4 +126,4 @@ Rasa.Internal.ListenersSpec Rasa.Internal.RangeSpec Rasa.Internal.TextSpec - ghc-options: -threaded -rtsopts -with-rtsopts=-N + ghc-options: -threaded -rtsopts -with-rtsopts=-N -fno-warn-orphans diff --git a/src/Rasa.hs b/src/Rasa.hs --- a/src/Rasa.hs +++ b/src/Rasa.hs @@ -1,12 +1,10 @@ {-# language ExistentialQuantification, Rank2Types, ScopedTypeVariables #-} module Rasa (rasa) where -import Rasa.Internal.Editor -import Rasa.Internal.Action -import Rasa.Internal.Events import Rasa.Internal.Listeners +import Rasa.Internal.Action +import Rasa.Internal.Interpreters -import Control.Lens import Control.Monad import Control.Monad.IO.Class import Data.Maybe @@ -28,24 +26,25 @@ -- > slate rasa :: Action () -> IO () -rasa initilize = do +rasa initialize = do (output, input) <- spawn unbounded evalAction (mkActionState output) $ do - initilize - dispatchEvent Init + initialize + dispatchInit + dispatchAfterInit eventLoop $ fromInput input - dispatchEvent Exit + dispatchExit -- | This is the main event loop, it runs recursively forever until something -- sets 'Rasa.Editor.exiting'. It runs the pre-event listeners, then checks if any -- async events have finished, then runs the post event listeners and repeats. eventLoop :: Producer (Action ()) IO () -> Action () eventLoop producer = do - dispatchEvent BeforeRender - dispatchEvent OnRender - dispatchEvent AfterRender - dispatchEvent BeforeEvent + dispatchBeforeRender + dispatchOnRender + dispatchAfterRender + dispatchBeforeEvent (mAction, nextProducer) <- liftIO $ runStateT draw producer fromMaybe (return ()) mAction - isExiting <- use exiting + isExiting <- shouldExit unless isExiting $ eventLoop nextProducer diff --git a/src/Rasa/Ext.hs b/src/Rasa/Ext.hs --- a/src/Rasa/Ext.hs +++ b/src/Rasa/Ext.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE Rank2Types, FlexibleContexts #-} - ---------------------------------------------------------------------------- -- | -- Module : Rasa.Ext @@ -24,13 +22,14 @@ -- -- > logKeypress :: Keypress -> Action () -- > logKeypress (Keypress char _) = liftIO $ appendFile "logs" ("You pressed " ++ [char] ++ "\n") +-- > logKeypress _ = return () -- > -- > logger :: Action () -- > logger = do -- > onInit $ liftIO $ writeFile "logs" "==Logs==\n" -- > -- Listeners should also be registered using 'onInit'. -- > -- It ensures all listeners are ready before any actions occur. --- > onInit $ onEveryTrigger_ logKeypress +-- > onInit $ onKeypress logKeypress -- > onExit $ liftIO $ appendFile "logs" "==Done==" -- -- Check out this tutorial on building extensions, it's also just a great way to learn @@ -41,15 +40,15 @@ ( -- * Editor Actions Action + , getBuffer + , getEditor , exit -- * Managing Buffers - , newBuffer + , addBuffer , nextBufRef , prevBufRef , getBufRefs - , getBuffers - , getBuffer -- * Working with Buffers , Buffer @@ -59,6 +58,7 @@ , HasEditor , getText , getRange + , getBufRef -- * Actions over Buffers , BufAction @@ -74,6 +74,7 @@ , deleteRange , insertAt , sizeOf + , getLineRange -- * Working with Extensions -- | Extension states for ALL the extensions installed are stored in the same @@ -85,7 +86,8 @@ -- it. -- -- Because Extension states are stored by their 'Data.Typeable.TypeRep', they must define an - -- instance of 'Data.Typeable.Typeable', luckily GHC can derive this for you. + -- instance of 'Data.Typeable.Typeable', luckily GHC can derive this for you with + -- @deriving Typeable@. -- -- It is also required for all extension states to define an instance of -- 'Data.Default.Default', this is because accessing an extension which has not @@ -105,49 +107,86 @@ -- it'll all work out. -- -- Since it's polymorphic, if ghc can't figure out the type the result is - -- supposed to be then you'll need to help it out. In practice you won't - -- typically need to do this unless you're doing something complicated. + -- supposed to be then you'll need to help it out with a type annotation. + -- In practice you won't typically need to do this unless you're + -- doing something complicated. , HasExts(..) , ext - , HasBufExts(..) - , bufExt + , getExt + , setExt + , overExt + , getBufExt + , setBufExt + , overBufExt + -- * Events - , Keypress(..) - , Mod(..) - -- * Dealing with events - , ListenerId + -- | 'dispatchEvent' and 'addListener' are key parts of working with extensions. + -- Here's an example of how you might use them in some sort of clipboard extensions: + -- + -- > -- The event type which is triggered whenever something is copied to clipboard + -- > data Copied = Copied Y.YiString + -- > + -- > -- This registers functions to be run when something is copied. + -- > -- you can see this is just addListener but with a more concrete type. + -- > onCopy :: (Copied -> Action ()) -> Action ListenerId + -- > onCopy = addListener + -- > + -- > -- This takes a Copied event and runs all the listeners associated. + -- > -- You can see it's just 'dispatchEvent' with a more concrete type. + -- > doCopy :: Copied -> Action () + -- > doCopy = dispatchEvent + -- > + -- > copier :: Action () + -- > copier = do + -- > -- ... do some stuff + -- > doCopy $ Copied copiedTxt + -- , dispatchEvent - , onEveryTrigger - , onEveryTrigger_ - , onNextEvent + , addListener + , addListener_ , removeListener + , dispatchBufEvent + , addBufListener + , addBufListener_ + , removeBufListener + + , ListenerId + + -- * Built-in Events + , Keypress(..) + , Mod(..) + , dispatchKeypress + , BufAdded(..) + , BufTextChanged(..) + -- * Built-in Event Listeners , onInit + , afterInit , beforeEveryEvent , beforeEveryEvent_ - , beforeNextEvent , beforeEveryRender , beforeEveryRender_ - , beforeNextRender , onEveryRender , onEveryRender_ - , onNextRender , afterEveryRender , afterEveryRender_ - , afterNextRender , onExit , onBufAdded + , onBufAdded_ + , onEveryNewBuffer + , onEveryNewBuffer_ , onBufTextChanged + , onKeypress -- * Working with Async Events/Actions - , Dispatcher , dispatchActionAsync , dispatchEventAsync - , asyncEventProvider , asyncActionProvider + , asyncEventProvider + , Dispatcher -- * Ranges , Range(..) @@ -174,21 +213,46 @@ , moveRangeByN , moveCursorByN + -- * Styles + -- | A common representation for text styling + , fg + , bg + , flair + , Color(..) + , Flair(..) + , Style(..) + , Styles + , addStyleProvider + , getStyles + , styleText + -- * Useful Utilities , asText , asString , asLines , clamp + , cropToViewport + + -- * Common Types/Interfaces + -- | These exist to help unify the interfaces of many different extensions without + -- requiring them to depend upon each other. Use them liberally in your own extensions. + , Width + , Height + , ScrollPos + , RenderInfo(..) + , Renderable(..) ) where import Rasa.Internal.Action import Rasa.Internal.Actions -import Rasa.Internal.Async import Rasa.Internal.BufAction +import Rasa.Internal.BufActions import Rasa.Internal.Buffer import Rasa.Internal.Editor import Rasa.Internal.Events import Rasa.Internal.Extensions -import Rasa.Internal.Range import Rasa.Internal.Listeners +import Rasa.Internal.Range +import Rasa.Internal.Styles import Rasa.Internal.Text +import Rasa.Internal.Utility diff --git a/src/Rasa/Internal/Action.hs b/src/Rasa/Internal/Action.hs --- a/src/Rasa/Internal/Action.hs +++ b/src/Rasa/Internal/Action.hs @@ -1,137 +1,109 @@ -{-# language DeriveFunctor - , MultiParamTypeClasses - , FlexibleInstances - , GeneralizedNewtypeDeriving - , Rank2Types - , ExistentialQuantification - , TemplateHaskell #-} module Rasa.Internal.Action ( Action(..) - , runAction - , evalAction - , execAction - , ActionState - , mkActionState - , Listener(..) - , ListenerId(..) - , Listeners - , listeners - , nextListenerId - , actionQueue + , dispatchActionAsync + , asyncActionProvider + , bufferDo + , addBuffer + , getBufRefs + , getExt + , setExt + , overExt + , exit + , shouldExit + , getBuffer + , getEditor ) where +import Rasa.Internal.ActionMonads import Rasa.Internal.Editor +import Rasa.Internal.Buffer import Rasa.Internal.Extensions -import Control.Lens -import Control.Monad.Free -import Control.Monad.State - -import Data.Default -import Data.Map -import Data.Typeable - -import Pipes.Concurrent hiding (Buffer) - --- | A wrapper around event listeners so they can be stored in 'Listeners'. -data Listener = forall a. Listener ListenerId (a -> Action ()) - --- | An opaque reverence to a specific registered event-listener. --- A ListenerId is used only to remove listeners later with 'Rasa.Internal.Listeners.removeListener'. -data ListenerId = - ListenerId Int TypeRep - -instance Eq ListenerId where - ListenerId a _ == ListenerId b _ = a == b - --- | A map of Event types to a list of listeners for that event -type Listeners = Map TypeRep [Listener] +import qualified Yi.Rope as Y --- | Free Monad Actions for Action -data ActionF state next = - LiftState (state -> (next, state)) - | LiftIO (IO next) - deriving (Functor) +-- | dispatchActionAsync allows you to perform a task asynchronously and then apply the +-- result. In @dispatchActionAsync asyncAction@, @asyncAction@ is an IO which resolves to +-- an Action, note that the context in which the second action is executed is +-- NOT the same context in which dispatchActionAsync is called; it is likely that text and +-- other state have changed while the IO executed, so it's a good idea to check +-- (inside the applying Action) that things are in a good state before making +-- changes. Here's an example: +-- +-- > asyncCapitalize :: Action () +-- > asyncCapitalize = do +-- > txt <- focusDo getText +-- > -- We give dispatchActionAsync an IO which resolves in an action +-- > dispatchActionAsync $ ioPart txt +-- > +-- > ioPart :: Text -> IO (Action ()) +-- > ioPart txt = do +-- > result <- longAsyncronousCapitalizationProgram txt +-- > -- Note that this returns an Action, but it's still wrapped in IO +-- > return $ maybeApplyResult txt result +-- > +-- > maybeApplyResult :: Text -> Text -> Action () +-- > maybeApplyResult oldTxt capitalized = do +-- > -- We get the current buffer's text, which may have changed since we started +-- > newTxt <- focusDo getText +-- > if newTxt == oldTxt +-- > -- If the text is the same as it was, we can apply the transformation +-- > then focusDo (setText capitalized) +-- > -- Otherwise we can choose to re-queue the whole action and try again +-- > -- Or we could just give up. +-- > else asyncCapitalize +dispatchActionAsync :: IO (Action ()) -> Action () +dispatchActionAsync ioAction = liftActionF $ DispatchActionAsync ioAction () --- | This is a monad for performing actions against the editor. --- You can register Actions to be run in response to events using 'Rasa.Internal.Listeners.onEveryTrigger' +-- | Don't let the type signature confuse you; it's much simpler than it seems. +-- The first argument is a function which takes an action provider; the action provider +-- will be passed a dispatch function which can be called as often as you like with @Action ()@s. +-- When it is passed an 'Action' it forks off an IO to dispatch that 'Action' to the main event loop. +-- Note that the dispatch function calls forkIO on its own; so there's no need for you to do so. -- --- Within an Action you can: +-- Use this function when you have some long-running process which dispatches multiple 'Action's. -- --- * Use liftIO for IO --- * Access/edit extensions that are stored globally, see 'ext' --- * Embed any 'Action's exported other extensions --- * Embed buffer actions using 'Rasa.Internal.Actions.bufDo' or 'Rasa.Internal.Actions.buffersDo' --- * Add\/Edit\/Focus buffers and a few other Editor-level things, see the "Rasa.Internal.Actions" module. -newtype Action a = Action - { getAction :: Free (ActionF ActionState) a - } deriving (Functor, Applicative, Monad) - --- | This contains all data representing the editor's state. It acts as the state object for an 'Action -data ActionState = ActionState - { _ed :: Editor - , _listeners :: Listeners - , _nextListenerId :: Int - , _actionQueue :: Output (Action ()) - } -makeLenses ''ActionState - -instance Show ActionState where - show as = show (_ed as) - -mkActionState :: Output (Action ()) -> ActionState -mkActionState out = ActionState - { _ed=def - , _listeners=def - , _nextListenerId=0 - , _actionQueue=out - } - -instance HasEditor ActionState where - editor = ed - -instance HasExts ActionState where - exts = ed.exts - --- | Embeds a ActionF type into the Action Monad -liftActionF :: ActionF ActionState a -> Action a -liftActionF = Action . liftF - --- | Allows running state actions over ActionState; used to lift mtl state functions -liftState :: (ActionState -> (a, ActionState)) -> Action a -liftState = liftActionF . LiftState - --- | Allows running IO in BufAction. -liftFIO :: IO r -> Action r -liftFIO = liftActionF . LiftIO +-- Here's an example which fires a @Timer@ event every second. +-- +-- > data Timer = TimerFired +-- > dispatchTimer :: Action () +-- > dispatchTimer = mkDispatcher Timer +-- > myTimer :: (Action () -> IO ()) -> IO () +-- > myTimer dispatch = forever $ dispatch dispatchTimer >> threadDelay 1000000 +-- > +-- > myAction :: Action () +-- > myAction = onInit $ asyncActionProvider myTimer -instance (MonadState ActionState) Action where - state = liftState +asyncActionProvider :: ((Action () -> IO ()) -> IO ()) -> Action () +asyncActionProvider asyncActionProv = liftActionF $ AsyncActionProvider asyncActionProv () -instance MonadIO Action where - liftIO = liftFIO +-- | Runs a BufAction over the given BufRefs, returning any results. +-- +-- Result list is not guaranteed to be the same length or positioning as input BufRef list; some buffers may no +-- longer exist. +bufferDo :: [BufRef] -> BufAction r -> Action [r] +bufferDo bufRefs bufAct = liftActionF $ BufferDo bufRefs bufAct id --- | Runs an Action into an IO -runAction :: ActionState -> Action a -> IO (a, ActionState) -runAction actionState (Action actionF) = actionInterpreter actionState actionF +-- | Adds a new buffer and returns the BufRef +addBuffer :: Y.YiString -> Action BufRef +addBuffer txt = liftActionF $ AddBuffer txt id --- | Evals an Action into an IO -evalAction :: ActionState -> Action a -> IO a -evalAction actionState action = fst <$> runAction actionState action +-- | Returns an up-to-date list of all 'BufRef's +getBufRefs :: Action [BufRef] +getBufRefs = liftActionF $ GetBufRefs id --- | Execs an Action into an IO -execAction :: ActionState -> Action a -> IO ActionState -execAction actionState action = snd <$> runAction actionState action +-- | Retrieve the entire editor state. This is read-only for logging/rendering/debugging purposes only. +getEditor :: Action Editor +getEditor = liftActionF $ GetEditor id --- | Interpret the Free Monad; in this case it interprets it down to an IO -actionInterpreter :: ActionState -> Free (ActionF ActionState) r -> IO (r, ActionState) -actionInterpreter actionState (Free actionF) = - case actionF of - (LiftState stateFunc) -> - let (next, newState) = stateFunc actionState - in actionInterpreter newState next +-- | Retrieve a buffer. This is read-only for logging/rendering/debugging purposes only. +getBuffer :: BufRef -> Action (Maybe Buffer) +getBuffer bufRef = liftActionF $ GetBuffer bufRef id - (LiftIO ioNext) -> - ioNext >>= actionInterpreter actionState +-- | This signals to the editor that you'd like to shutdown. The current events +-- will finish processing, then the 'Rasa.Internal.Listeners.onExit' event will be dispatched, +-- then the editor will exit. +exit :: Action () +exit = liftActionF $ Exit () -actionInterpreter actionState (Pure res) = return (res, actionState) +shouldExit :: Action Bool +shouldExit = liftActionF $ ShouldExit id diff --git a/src/Rasa/Internal/ActionMonads.hs b/src/Rasa/Internal/ActionMonads.hs new file mode 100644 --- /dev/null +++ b/src/Rasa/Internal/ActionMonads.hs @@ -0,0 +1,120 @@ +{-# language + DeriveFunctor + , GADTs + , GeneralizedNewtypeDeriving + , StandaloneDeriving +#-} +module Rasa.Internal.ActionMonads + ( Action(..) + , BufAction(..) + , ActionF(..) + , BufActionF(..) + , liftActionF + , liftBufAction + ) where + +import Rasa.Internal.Editor +import Rasa.Internal.Extensions +import Rasa.Internal.Buffer +import Rasa.Internal.Range + +import Control.Monad.Free +import Control.Monad.IO.Class + +import Data.Default +import Data.Typeable + +import qualified Yi.Rope as Y + +-- | Free Monad Actions for Action +data ActionF next where + LiftIO :: IO next -> ActionF next + BufferDo :: [BufRef] -> BufAction r -> ([r] -> next) -> ActionF next + DispatchActionAsync :: IO (Action ()) -> next -> ActionF next + AsyncActionProvider :: ((Action () -> IO ()) -> IO ()) -> next -> ActionF next + AddBuffer :: Y.YiString -> (BufRef -> next) -> ActionF next + GetBufRefs :: ([BufRef] -> next) -> ActionF next + GetExt :: (Typeable ext, Show ext, Default ext) => (ext -> next) -> ActionF next + SetExt :: (Typeable ext, Show ext, Default ext) => ext -> next -> ActionF next + GetEditor :: (Editor -> next) -> ActionF next + GetBuffer :: BufRef -> (Maybe Buffer -> next) -> ActionF next + Exit :: next -> ActionF next + ShouldExit :: (Bool -> next) -> ActionF next +deriving instance Functor ActionF + +-- | Embeds a ActionF type into the Action Monad +liftActionF :: ActionF a -> Action a +liftActionF = Action . liftF + +-- | Allows running IO in BufAction. +liftFIO :: IO r -> Action r +liftFIO = liftActionF . LiftIO + +instance MonadIO Action where + liftIO = liftFIO + +instance HasExtMonad Action where + -- | Retrieve some extension state + getExt = liftActionF $ GetExt id + + -- | Set some extension state + setExt newExt = liftActionF $ SetExt newExt () + +-- | This is a monad for performing actions against the editor. +-- You can register Actions to be run in response to events using 'Rasa.Internal.Listeners.onEveryTrigger' +-- +-- Within an Action you can: +-- +-- * Use liftIO for IO +-- * Access/edit extensions that are stored globally, see 'ext' +-- * Embed any 'Action's exported other extensions +-- * Embed buffer actions using 'Rasa.Internal.Actions.bufDo' or 'Rasa.Internal.Actions.buffersDo' +-- * Add\/Edit\/Focus buffers and a few other Editor-level things, see the "Rasa.Internal.Actions" module. +newtype Action a = Action + { getAction :: Free ActionF a + } deriving (Functor, Applicative, Monad) + +-- | Free Monad Actions for BufAction +data BufActionF next where + GetText :: (Y.YiString -> next) -> BufActionF next + SetText :: Y.YiString -> next -> BufActionF next + GetBufRef :: (BufRef -> next) -> BufActionF next + GetBufExt :: (Typeable ext, Show ext, Default ext) => (ext -> next) -> BufActionF next + SetBufExt :: (Typeable ext, Show ext, Default ext) => ext -> next -> BufActionF next + SetRange :: CrdRange -> Y.YiString -> next -> BufActionF next + LiftAction :: Action r -> (r -> next) -> BufActionF next + BufLiftIO :: IO next -> BufActionF next +deriving instance Functor BufActionF + +-- | This is a monad for performing actions on a specific buffer. +-- You run 'BufAction's by embedding them in a 'Action' via 'Rasa.Internal.Actions.bufferDo' or +-- 'Rasa.Internal.Actions.buffersDo' +-- +-- Within a BufAction you can: +-- +-- * Use 'liftAction' to run an 'Action' +-- * Use liftIO for IO +-- * Access/Edit the buffer's text; some commands are available in "Rasa.Internal.Actions". +-- * Access/edit buffer extensions; see 'bufExt' +-- * Embed and sequence 'BufAction's from other extensions +newtype BufAction a = BufAction + { getBufAction :: Free BufActionF a + } deriving (Functor, Applicative, Monad) + +-- | Embeds a BufActionF type into the BufAction Monad +liftBufAction :: BufActionF a -> BufAction a +liftBufAction = BufAction . liftF + +-- | Allows running IO in BufAction. +liftBufActionFIO :: IO r -> BufAction r +liftBufActionFIO = liftBufAction . BufLiftIO + +instance MonadIO BufAction where + liftIO = liftBufActionFIO + +instance HasExtMonad BufAction where + -- | Retrieve some buffer extension state + getExt = liftBufAction $ GetBufExt id + + -- | Set some buffer extension state + setExt newExt = liftBufAction $ SetBufExt newExt () diff --git a/src/Rasa/Internal/Actions.hs b/src/Rasa/Internal/Actions.hs --- a/src/Rasa/Internal/Actions.hs +++ b/src/Rasa/Internal/Actions.hs @@ -1,4 +1,8 @@ -{-# language Rank2Types, OverloadedStrings #-} +{-# language + Rank2Types + , OverloadedStrings + , ScopedTypeVariables +#-} module Rasa.Internal.Actions ( -- * Performing Actions on Buffers @@ -9,37 +13,18 @@ -- * Editor Actions , exit - , newBuffer , getBufRefs - , getBuffers - , getBuffer , nextBufRef , prevBufRef - - -- * Buffer Actions - , overRange - , replaceRange - , deleteRange - , insertAt - , sizeOf ) where import Rasa.Internal.Editor import Rasa.Internal.Action import Rasa.Internal.BufAction -import Rasa.Internal.Range -import Rasa.Internal.Listeners -import Rasa.Internal.Events -import Rasa.Internal.Buffer as B -import Control.Lens import Control.Monad -import Control.Arrow (first) import Data.Maybe -import Data.IntMap as M -import qualified Yi.Rope as Y - -- | This lifts a 'Rasa.Action.BufAction' to an 'Rasa.Action.Action' which -- performs the 'Rasa.Action.BufAction' on every buffer and collects the return -- values as a list. @@ -47,7 +32,7 @@ buffersDo :: BufAction a -> Action [a] buffersDo bufAct = do bufRefs <- getBufRefs - catMaybes . foldMap (:[]) <$> mapM (runBufAction bufAct) bufRefs + bufferDo bufRefs bufAct buffersDo_ :: BufAction a -> Action () buffersDo_ = void . buffersDo @@ -56,80 +41,27 @@ -- performs the 'Rasa.Internal.Action.BufAction' on the buffer referred to by the 'BufRef' -- If the buffer referred to no longer exists this returns: @Nothing@. bufDo :: BufRef -> BufAction a -> Action (Maybe a) -bufDo bufRef bufAct = runBufAction bufAct bufRef +bufDo bufRef bufAct = listToMaybe <$> bufferDo [bufRef] bufAct bufDo_ :: BufRef -> BufAction a -> Action () bufDo_ bufRef bufAct = void $ bufDo bufRef bufAct --- | This adds a new buffer with the given text, returning a reference to that buffer. -newBuffer :: Y.YiString -> Action BufRef -newBuffer txt = do - n <- nextBufId <<+= 1 - buffers %= insert n (mkBuffer txt) - let bufRef = BufRef n - dispatchEvent (BufAdded bufRef) - return bufRef - --- | Returns an up-to-date list of all 'BufRef's -getBufRefs :: Action [BufRef] -getBufRefs = fmap BufRef <$> use (buffers.to keys) - --- | Returns the 'Buffer' for a BufRef if it still exists. --- This is read-only; altering the buffer has no effect on the stored buffer. --- This function is useful for renderers. -getBuffer :: BufRef -> Action (Maybe Buffer) -getBuffer (BufRef bufInt) = use (buffers.at bufInt) - --- | Returns an up-to-date list of all 'Buffer's, returned values --- are read-only; altering them has no effect on the actual stored buffers. --- This function is useful for renderers. -getBuffers :: Action [(BufRef, Buffer)] -getBuffers = fmap (first BufRef) <$> use (buffers.to assocs) - -- | Gets 'BufRef' that comes after the one provided nextBufRef :: BufRef -> Action BufRef -nextBufRef br@(BufRef bufInt) = do - bufMap <- use buffers - if M.null bufMap - then return br - else do - let mGreaterInd = lookupGT bufInt bufMap - case mGreaterInd of - Just (greaterInd, _) -> return $ BufRef greaterInd - Nothing -> return . BufRef . fst . findMin $ bufMap +nextBufRef br = do + bufRefs <- getBufRefs + return $ if null bufRefs + then br + else case dropWhile (<= br) bufRefs of + [] -> head bufRefs + (x:_) -> x -- | Gets 'BufRef' that comes before the one provided prevBufRef :: BufRef -> Action BufRef -prevBufRef br@(BufRef bufInt) = do - bufMap <- use buffers - if M.null bufMap - then return br - else do - let mLesserInd = lookupLT bufInt bufMap - case mLesserInd of - Just (lesserInd, _) -> return $ BufRef lesserInd - Nothing -> return . BufRef . fst . findMax $ bufMap - --- | This signals to the editor that you'd like to shutdown. The current events --- will finish processing, then the 'Rasa.Internal.Listeners.onExit' event will be dispatched, --- then the editor will exit. - -exit :: Action () -exit = exiting .= True - --- | Runs function over given range of text -overRange :: CrdRange -> (Y.YiString -> Y.YiString) -> BufAction () -overRange r f = getRange r >>= setRange r . f - --- | Deletes the text in the given range from the buffer. -deleteRange :: CrdRange -> BufAction () -deleteRange r = replaceRange r "" - --- | Replaces the text in the given range with the given text. -replaceRange :: CrdRange -> Y.YiString -> BufAction () -replaceRange r txt = overRange r (const txt) - --- | Inserts text into the buffer at the given 'Coord'. -insertAt :: Coord -> Y.YiString -> BufAction () -insertAt c = replaceRange r - where r = Range c c +prevBufRef br = do + bufRefs <- getBufRefs + return $ if null bufRefs + then br + else case dropWhile (>= br) (reverse bufRefs) of + [] -> last bufRefs + (x:_) -> x diff --git a/src/Rasa/Internal/Async.hs b/src/Rasa/Internal/Async.hs deleted file mode 100644 --- a/src/Rasa/Internal/Async.hs +++ /dev/null @@ -1,129 +0,0 @@ -{-# language Rank2Types, ExistentialQuantification #-} -module Rasa.Internal.Async - ( asyncEventProvider - , Dispatcher - , asyncActionProvider - , dispatchEventAsync - , dispatchActionAsync -) where - -import Rasa.Internal.Action -import Rasa.Internal.Listeners - -import Control.Lens -import Control.Monad.IO.Class - -import Data.Typeable - -import Pipes -import Pipes.Concurrent - --- | A helper which when given an output channel results in a function from @Action () -> IO ()@ which --- dispatches any actions it's called with asyncronously to the main event loop. -dispatchAction :: Output (Action ()) -> Action () -> IO () -dispatchAction output act = - void . forkIO $ do runEffect $ yield act >-> toOutput output - performGC - --- | This function takes an IO which results in some Event, it runs the IO --- asynchronously and dispatches the event -dispatchEventAsync :: Typeable a => IO a -> Action () -dispatchEventAsync getEventIO = do - out <- use actionQueue - liftIO $ void . forkIO $ do runEffect $ producer >-> toOutput out - performGC - where - producer :: Producer (Action ()) IO () - producer = do - evt <- lift getEventIO - yield (dispatchEvent evt) - --- | This allows long-running IO processes to provide Events to Rasa asyncronously. --- --- Don't let the type signature confuse you; it's much simpler than it seems. --- --- Let's break it down: --- --- @('Dispatcher' -> 'IO' ())@: 'Dispatcher' is a type alias just to make defining your own functions easier; --- Using 'Dispatcher' with asyncEventProvider requires the @Rank2Types@ language pragma. --- --- This type as a whole represents a function which accepts a 'Dispatcher' and returns an 'IO'; --- the dispatcher itself accepts data of ANY 'Typeable' type and emits it as an event (see the "Rasa.Internal.Events"). --- --- When you call 'asyncEventProvider' you pass it a function which accepts a @dispatch@ function as an argument --- and then calls it with various events within the resulting 'IO'. --- --- Note that asyncEventProvider calls forkIO internally, so there's no need to do that yourself. --- --- Here's a simple example which fires a @Timer@ event every second. --- --- > {-# language Rank2Types #-} --- > data Timer = Timer --- > myTimer :: Dispatcher -> IO () --- > myTimer dispatch = forever $ dispatch Timer >> threadDelay 1000000 --- > --- > myAction :: Action () --- > myAction = onInit $ asyncEventProvider myTimer - -asyncEventProvider :: (Dispatcher -> IO ()) -> Action () -asyncEventProvider eventProvidingIO = do - out <- use actionQueue - liftIO $ void . forkIO $ eventProvidingIO (dispatchAction out . dispatchEvent) - --- | This is a type alias to make defining your event provider functions easier; --- It represents the function your event provider function will be passed to allow dispatching --- events. Using this type requires the @Rank2Types@ language pragma. -type Dispatcher = forall a. Typeable a => a -> IO () - --- | Don't let the type signature confuse you; it's much simpler than it seems. --- The first argument is a function which takes an action provider; the action provider --- will be passed a dispatch function which can be called as often as you like with @Action ()@s. --- When it is passed an 'Action' it forks off an IO to dispatch that 'Action' to the main event loop. --- Note that the dispatch function calls forkIO on its own; so there's no need for you to do so. --- --- Use this function when you have some long-running process which dispatches multiple 'Action's. - -asyncActionProvider :: ((Action () -> IO ()) -> IO ()) -> Action () -asyncActionProvider actionProvidingIO = do - out <- use actionQueue - liftIO $ void . forkIO $ actionProvidingIO (dispatchAction out) - --- | dispatchActionAsync allows you to perform a task asynchronously and then apply the --- result. In @dispatchActionAsync asyncAction@, @asyncAction@ is an IO which resolves to --- an Action, note that the context in which the second action is executed is --- NOT the same context in which dispatchActionAsync is called; it is likely that text and --- other state have changed while the IO executed, so it's a good idea to check --- (inside the applying Action) that things are in a good state before making --- changes. Here's an example: --- --- > asyncCapitalize :: Action () --- > asyncCapitalize = do --- > txt <- focusDo $ use text --- > -- We give dispatchActionAsync an IO which resolves in an action --- > dispatchActionAsync $ ioPart txt --- > --- > ioPart :: Text -> IO (Action ()) --- > ioPart txt = do --- > result <- longAsyncronousCapitalizationProgram txt --- > -- Note that this returns an Action, but it's still wrapped in IO --- > return $ maybeApplyResult txt result --- > --- > maybeApplyResult :: Text -> Text -> Action () --- > maybeApplyResult oldTxt capitalized = do --- > -- We get the current buffer's text, which may have changed since we started --- > newTxt <- focusDo (use text) --- > if newTxt == oldTxt --- > -- If the text is the same as it was, we can apply the transformation --- > then focusDo (text .= capitalized) --- > -- Otherwise we can choose to re-queue the whole action and try again --- > -- Or we could just give up. --- > else asyncCapitalize - -dispatchActionAsync :: IO (Action ()) -> Action () -dispatchActionAsync asyncIO = do - queue <- use actionQueue - liftIO $ void $ forkIO $ do runEffect $ producer >-> toOutput queue - performGC - where producer = do - action <- lift asyncIO - yield action diff --git a/src/Rasa/Internal/BufAction.hs b/src/Rasa/Internal/BufAction.hs --- a/src/Rasa/Internal/BufAction.hs +++ b/src/Rasa/Internal/BufAction.hs @@ -1,58 +1,26 @@ -{-# language DeriveFunctor - , MultiParamTypeClasses - , FlexibleInstances - , GeneralizedNewtypeDeriving - , Rank2Types - , TemplateHaskell #-} module Rasa.Internal.BufAction ( BufAction(..) , getText , setText + , getBufRef , getRange , setRange - , liftState + , getBufExt + , setBufExt + , overBufExt , liftAction - , runBufAction ) where -import Rasa.Internal.Buffer -import Rasa.Internal.Editor -import Rasa.Internal.Action +import Rasa.Internal.ActionMonads import Rasa.Internal.Range -import Rasa.Internal.Listeners -import Rasa.Internal.Events -import Rasa.Internal.Extensions +import Rasa.Internal.Buffer import Control.Lens -import Control.Monad.Free -import Control.Monad.State +import Data.Default +import Data.Typeable import qualified Yi.Rope as Y --- | Contains all data about the editor; as well as a buffer which is in 'focus'. --- We keep the full ActionState here too so that 'Action's may be lifted inside a 'BufAction' -data BufActionState = BufActionState - { _buffer' :: Buffer - , _actionState :: ActionState - } -makeLenses ''BufActionState - -instance HasBufExts BufActionState where - bufExts = buffer'.bufExts - --- | Free Monad Actions for BufAction -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) - --- | Embeds a BufActionF type into the BufAction Monad -liftBufAction :: BufActionF BufActionState a -> BufAction a -liftBufAction = BufAction . liftF - -- | Returns the text of the current buffer getText :: BufAction Y.YiString getText = liftBufAction $ GetText id @@ -69,82 +37,22 @@ setRange :: CrdRange -> Y.YiString -> BufAction () setRange rng txt = liftBufAction $ SetRange rng txt () --- | Allows running state actions over BufActionState; used to lift mtl state functions -liftState :: (BufActionState -> (a, BufActionState)) -> BufAction a -liftState = liftBufAction . LiftState - --- | Allows running IO in BufAction. -liftFIO :: IO r -> BufAction r -liftFIO = liftBufAction . LiftIO +-- | Gets the current buffer's 'BufRef' +getBufRef :: BufAction BufRef +getBufRef = liftBufAction $ GetBufRef id --- | This is a monad for performing actions on a specific buffer. --- You run 'BufAction's by embedding them in a 'Action' via 'Rasa.Internal.Actions.bufferDo' or --- 'Rasa.Internal.Actions.buffersDo' --- --- Within a BufAction you can: --- --- * Use 'liftAction' to run an 'Action' --- * Use liftIO for IO --- * Access/Edit the buffer's text; some commands are available in "Rasa.Internal.Actions". --- * Access/edit buffer extensions; see 'bufExt' --- * Embed and sequence 'BufAction's from other extensions -newtype BufAction a = BufAction - { getBufAction :: Free (BufActionF BufActionState) a - } deriving (Functor, Applicative, Monad) +-- | Retrieve some buffer extension state +getBufExt :: (Typeable ext, Show ext, Default ext) => BufAction ext +getBufExt = liftBufAction $ GetBufExt id -instance (MonadState BufActionState) BufAction where - state = liftState +-- | Set some buffer extension state +setBufExt :: (Typeable ext, Show ext, Default ext) => ext -> BufAction () +setBufExt newExt = liftBufAction $ SetBufExt newExt () -instance MonadIO BufAction where - liftIO = liftFIO +-- | Set some buffer extension state +overBufExt :: (Typeable ext, Show ext, Default ext) => (ext -> ext) -> BufAction () +overBufExt f = getBufExt >>= setBufExt . f -- | This lifts up an 'Action' to be run inside a 'BufAction' 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 - --- | This lifts up a bufAction into an Action which performs the 'BufAction' --- over the referenced buffer and returns the result (if the buffer existed) -runBufAction :: BufAction a -> BufRef -> Action (Maybe a) -runBufAction (BufAction bufActF) = flip bufActionInterpreter bufActF - --- | Interpret the Free Monad; in this case it interprets it down to an Action. -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 +liftAction action = liftBufAction $ LiftAction action id diff --git a/src/Rasa/Internal/BufActions.hs b/src/Rasa/Internal/BufActions.hs new file mode 100644 --- /dev/null +++ b/src/Rasa/Internal/BufActions.hs @@ -0,0 +1,43 @@ +{-# language OverloadedStrings #-} +module Rasa.Internal.BufActions + ( overRange + , replaceRange + , deleteRange + , insertAt + , sizeOf + , getLineRange + ) where + +import Rasa.Internal.BufAction +import Rasa.Internal.Range +import Rasa.Internal.Text + +import Control.Lens +import qualified Yi.Rope as Y + +-- | Runs function over given range of text +overRange :: CrdRange -> (Y.YiString -> Y.YiString) -> BufAction () +overRange r f = getRange r >>= setRange r . f + +-- | Deletes the text in the given range from the buffer. +deleteRange :: CrdRange -> BufAction () +deleteRange r = replaceRange r "" + +-- | Replaces the text in the given range with the given text. +replaceRange :: CrdRange -> Y.YiString -> BufAction () +replaceRange r txt = overRange r (const txt) + +-- | Inserts text into the buffer at the given 'Coord'. +insertAt :: Coord -> Y.YiString -> BufAction () +insertAt c = replaceRange r + where r = Range c c + +-- | Rows can be represented by their line number. +type Row = Int + +-- | Gets the range representing a given row (if that row exists) +getLineRange :: Row -> BufAction (Maybe CrdRange) +getLineRange n = do + txt <- getText + let len = txt ^? asLines . ix n . to Y.length + return $ Range (Coord n 0) . Coord n <$> len diff --git a/src/Rasa/Internal/Buffer.hs b/src/Rasa/Internal/Buffer.hs --- a/src/Rasa/Internal/Buffer.hs +++ b/src/Rasa/Internal/Buffer.hs @@ -12,29 +12,42 @@ module Rasa.Internal.Buffer ( Buffer , HasBuffer(..) + , BufRef(..) , text , mkBuffer + , ref ) where import Rasa.Internal.Extensions import qualified Yi.Rope as Y import Control.Lens hiding (matching) -import Data.Map +import Data.Map as M +import Data.List +-- | An opaque reference to a buffer. +-- When operating over a BufRef Rasa checks if the 'Rasa.Internal.Buffer.Buffer' still +-- exists and simply ignores any operations over non-existent buffers; typically returning 'Nothing' +newtype BufRef = + BufRef Int + deriving (Show, Eq, Ord) + -- | A buffer, holds the text in the buffer and any extension states that are set on the buffer. data Buffer = Buffer { _text' :: Y.YiString , _bufExts' :: ExtMap + , _ref :: BufRef } makeLenses ''Buffer -instance HasBufExts Buffer where - bufExts = bufExts' +instance HasExts Buffer where + exts = bufExts' instance Show Buffer where - show b = "\n" + show b = "text:" ++ (Y.toString . Y.take 30 $ (b^.text)) ++ "...,\n" + ++ "exts: " ++ extText ++ "}>\n" + where + extText = intercalate "\n" $ show <$> b^.exts.to M.toList -- | This allows creation of polymorphic lenses over any type which has access to a Buffer class HasBuffer a where @@ -48,9 +61,10 @@ text = buffer.text' -- | Creates a new buffer from the given text. -mkBuffer :: Y.YiString -> Buffer -mkBuffer txt = +mkBuffer :: Y.YiString -> BufRef -> Buffer +mkBuffer txt bRef = Buffer { _text' = txt , _bufExts' = empty + , _ref = bRef } diff --git a/src/Rasa/Internal/Editor.hs b/src/Rasa/Internal/Editor.hs --- a/src/Rasa/Internal/Editor.hs +++ b/src/Rasa/Internal/Editor.hs @@ -13,7 +13,6 @@ , HasEditor(..) , buffers , exiting - , nextBufId , BufRef(..) ) where @@ -22,30 +21,28 @@ import Data.Default import Data.IntMap +import qualified Data.Map as M import Control.Lens - --- | An opaque reference to a buffer. --- When operating over a BufRef Rasa checks if the 'Rasa.Internal.Buffer.Buffer' still --- exists and simply ignores any operations over non-existent buffers; typically returning 'Nothing' -newtype BufRef = - BufRef Int - deriving (Show, Eq, Ord) +import Data.List -- | This is the primary state of the editor. data Editor = Editor { _buffers' :: IntMap Buffer , _exiting' :: Bool , _extState' :: ExtMap - , _nextBufId' :: Int } makeLenses ''Editor instance Show Editor where show ed = - "Buffers==============\n" ++ show (ed^.buffers) ++ "\n\n" - ++ "Editor Extensions==============\n" ++ show (ed^.exts) ++ "\n\n" + "Buffers==============\n" ++ bufferText ++ "\n\n" + ++ "Editor Extensions==============\n" ++ extText ++ "\n\n" ++ "---\n\n" + where + bufferText = intercalate "\n" $ zipWith ((++) . (++ ": ") . show) [(1::Integer)..] (ed^..buffers.traverse.to show) + extText = intercalate "\n" $ show <$> ed^.exts.to M.toList + -- | This allows polymorphic lenses over anything that has access to an Editor context class HasEditor a where editor :: Lens' a Editor @@ -58,10 +55,6 @@ exiting :: HasEditor e => Lens' e Bool exiting = editor.exiting' --- | A lens over the next buffer id to be allocated -nextBufId :: HasEditor e => Lens' e Int -nextBufId = editor.nextBufId' - instance HasEditor Editor where editor = lens id (flip const) @@ -74,5 +67,4 @@ { _extState'=def , _buffers'=empty , _exiting'=False - , _nextBufId'=0 } diff --git a/src/Rasa/Internal/Events.hs b/src/Rasa/Internal/Events.hs --- a/src/Rasa/Internal/Events.hs +++ b/src/Rasa/Internal/Events.hs @@ -1,6 +1,7 @@ {-# language ExistentialQuantification #-} module Rasa.Internal.Events ( Init(..) + , AfterInit(..) , BeforeEvent(..) , BeforeRender(..) , OnRender(..) @@ -20,6 +21,9 @@ -- | This event is dispatched exactly once when the editor starts up. data Init = Init deriving (Show, Eq, Typeable) +-- | This event is dispatched exactly once when the editor starts up after onInit has occurred. +data AfterInit = AfterInit deriving (Show, Eq, Typeable) + -- | This event is dispatched immediately before dispatching any events from -- asyncronous event listeners (like 'Keypress's) data BeforeEvent = BeforeEvent deriving (Show, Eq, Typeable) @@ -44,16 +48,21 @@ -- | This event is dispatched in response to keyboard key presses. It contains both -- the char that was pressed and any modifiers ('Mod') that where held when the key was pressed. data Keypress - = Keypress Char - [Mod] - | KEsc - | KBS - | KEnter + = Keypress Char [Mod] + | KEsc [Mod] + | KBS [Mod] + | KEnter [Mod] + | KLeft [Mod] + | KRight [Mod] + | KUp [Mod] + | KDown [Mod] + | KPrtScr [Mod] + | KHome [Mod] + | KPageUp [Mod] + | KDel [Mod] + | KEnd [Mod] + | KPageDown [Mod] | KUnknown - | KLeft - | KRight - | KUp - | KDown deriving (Show, Eq, Typeable) -- | This represents each modifier key that could be pressed along with a key. @@ -61,6 +70,7 @@ = Ctrl | Alt | Shift + | Meta deriving (Show, Eq) -- | This is triggered when text in a buffer is changed. The Event data includes the 'CrdRange' that changed and @@ -68,4 +78,3 @@ data BufTextChanged = BufTextChanged CrdRange Y.YiString deriving (Show, Eq, Typeable) - diff --git a/src/Rasa/Internal/Extensions.hs b/src/Rasa/Internal/Extensions.hs --- a/src/Rasa/Internal/Extensions.hs +++ b/src/Rasa/Internal/Extensions.hs @@ -2,9 +2,8 @@ module Rasa.Internal.Extensions ( Ext(..) , ExtMap - , HasBufExts(..) , HasExts(..) - , bufExt + , HasExtMonad(..) , ext ) where @@ -52,33 +51,13 @@ s coerce = iso (\(Ext x) -> unsafeCoerce x) Ext --- | Members of this class have access to buffer extensions. (Each 'Rasa.Internal.Buffer.Buffer' is a member of this class) -class HasBufExts s where - -- | This lens focuses the Extensions States map of the in-scope buffer. - bufExts :: Lens' s (Map TypeRep Ext) +class (Typeable m, Monad m) => HasExtMonad m where + -- | Retrieve some extension state + getExt :: (Typeable ext, Show ext, Default ext) => m ext --- | 'bufExt' is a lens which will focus a given extension's state within a --- buffer (within a 'Data.Action.BufAction'). The lens will automagically focus --- the required extension by using type inference. It's a little bit of magic, --- if you treat the focus as a member of your extension state it should just --- work out. --- --- This lens falls back on the extension's 'Data.Default.Default' instance (when getting) if --- nothing has yet been stored. + -- | Set some extension state + setExt :: (Typeable ext, Show ext, Default ext) => ext -> m () -bufExt - :: forall a s. - (Show a, Typeable a, Default a, HasBufExts s) - => Lens' s a -bufExt = lens getter setter - where - getter buf = - fromMaybe def $ buf ^. bufExts . at (typeRep (Proxy :: Proxy a)) . - mapping coerce - setter buf new = - set - (bufExts . at (typeRep (Proxy :: Proxy a)) . mapping coerce) - (Just new) - buf - coerce :: (Show a1) => Iso Ext Ext a a1 - coerce = iso (\(Ext x) -> unsafeCoerce x) Ext + -- | Set some extension state + overExt :: (Typeable ext, Show ext, Default ext) => (ext -> ext) -> m () + overExt f = getExt >>= setExt . f diff --git a/src/Rasa/Internal/Interpreters.hs b/src/Rasa/Internal/Interpreters.hs new file mode 100644 --- /dev/null +++ b/src/Rasa/Internal/Interpreters.hs @@ -0,0 +1,176 @@ +{-# language + TemplateHaskell +#-} + +module Rasa.Internal.Interpreters + ( runAction + , evalAction + , execAction + , bootstrapAction + , mkActionState + + , runBufAction + ) where + +import Rasa.Internal.ActionMonads +import Rasa.Internal.Buffer +import Rasa.Internal.Editor +import Rasa.Internal.Events hiding (Exit) +import Rasa.Internal.Extensions +import Rasa.Internal.Listeners +import Rasa.Internal.Range + +import Control.Monad.Free +import Control.Monad.State +import Control.Lens +import Data.Default +import Data.Maybe +import qualified Data.IntMap as IM + +import Pipes hiding (Proxy, next) +import Pipes.Concurrent hiding (Buffer) + +-- | This contains all data representing the editor's state. It acts as the state object for an 'Action +data ActionState = ActionState + { _ed :: Editor + , _nextBufId :: Int + , _actionQueue :: Output (Action ()) + } +makeLenses ''ActionState + +instance Show ActionState where + show as = show (_ed as) + +mkActionState :: Output (Action ()) -> ActionState +mkActionState out = ActionState + { _ed=def + , _nextBufId=0 + , _actionQueue=out + } + +instance HasEditor ActionState where + editor = ed + +instance HasExts ActionState where + exts = ed.exts + +-- | Runs an Action into an IO +runAction :: ActionState -> Action a -> IO (a, ActionState) +runAction actionState (Action actionF) = flip runStateT actionState $ actionInterpreter actionF + +-- | Evals an Action into an IO +evalAction :: ActionState -> Action a -> IO a +evalAction actionState action = fst <$> runAction actionState action + +-- | Execs an Action into an IO +execAction :: ActionState -> Action a -> IO ActionState +execAction actionState action = snd <$> runAction actionState action + +-- | Spawn the channels necessary to run action and do so. +bootstrapAction :: Action a -> IO a +bootstrapAction action = do + (output, _) <- spawn unbounded + evalAction (mkActionState output) action + +-- | Interpret the Free Monad; in this case it interprets it down to an IO +actionInterpreter :: Free ActionF r -> StateT ActionState IO r +actionInterpreter (Free actionF) = + case actionF of + (LiftIO ioNext) -> + liftIO ioNext >>= actionInterpreter + + (BufferDo bufRefs bufAct toNext) -> do + results <- forM bufRefs $ \(BufRef bInd) -> + use (buffers.at bInd) >>= traverse (handleBuf bInd) + actionInterpreter . toNext $ catMaybes results + where handleBuf bIndex buf = do + let Action act = runBufAction bufAct buf + (res, newBuffer) <- actionInterpreter act + buffers.at bIndex ?= newBuffer + return res + + (DispatchActionAsync asyncActionIO next) -> do + asyncQueue <- use actionQueue + let effect = (liftIO asyncActionIO >>= yield) >-> toOutput asyncQueue + liftIO . void . forkIO $ runEffect effect >> performGC + actionInterpreter next + + (AsyncActionProvider dispatcherToIO next) -> do + asyncQueue <- use actionQueue + let dispatcher action = + let effect = yield action >-> toOutput asyncQueue + in void . forkIO $ runEffect effect >> performGC + liftIO . void . forkIO $ dispatcherToIO dispatcher + actionInterpreter next + + (AddBuffer txt toNext) -> do + bufId <- nextBufId <+= 1 + let bufRef = BufRef bufId + buffers.at bufId ?= mkBuffer txt bufRef + let Action dBufAdded = dispatchBufAdded (BufAdded bufRef) + actionInterpreter (dBufAdded >> toNext bufRef) + + (GetBufRefs toNext) -> + use (buffers.to IM.keys) >>= actionInterpreter . toNext . fmap BufRef + + (GetExt toNext) -> + use ext >>= actionInterpreter . toNext + + (SetExt new next) -> do + ext .= new + actionInterpreter next + + (GetEditor toNext) -> + use ed >>= actionInterpreter . toNext + + (GetBuffer (BufRef bufInd) toNext) -> + use (buffers.at bufInd) >>= actionInterpreter . toNext + + (Exit next) -> do + exiting .= True + actionInterpreter next + + (ShouldExit toNext) -> do + ex <- use exiting + actionInterpreter (toNext ex) + +actionInterpreter (Pure res) = return res + +-- | This lifts up a bufAction into an Action which performs the 'BufAction' +-- over the referenced buffer and returns the result (if the buffer existed) +runBufAction :: BufAction a -> Buffer -> Action (a, Buffer) +runBufAction (BufAction bufActF) buf = flip runStateT buf $ bufActionInterpreter bufActF + +-- | Interpret the Free Monad; in this case it interprets it down to an Action. +bufActionInterpreter :: Free BufActionF r -> StateT Buffer Action r +bufActionInterpreter (Free bufActionF) = + case bufActionF of + (GetText nextF) -> use text >>= bufActionInterpreter . nextF + + (SetText newText next) -> do + text .= newText + bufActionInterpreter next + + (GetBufRef toNext) -> do + bref <- use ref + bufActionInterpreter $ toNext bref + + + (SetRange rng newText next) -> do + text.range rng .= newText + let (BufAction dispatchChange) = dispatchBufTextChanged $ BufTextChanged rng newText + bufActionInterpreter (dispatchChange >> next) + + (LiftAction act toNext) -> lift act >>= bufActionInterpreter . toNext + + (GetBufExt extToNext) -> + use ext >>= bufActionInterpreter . extToNext + + (SetBufExt new next) -> do + ext .= new + bufActionInterpreter next + + (BufLiftIO ioNext) -> + liftIO ioNext >>= bufActionInterpreter + +bufActionInterpreter (Pure res) = return res diff --git a/src/Rasa/Internal/Listeners.hs b/src/Rasa/Internal/Listeners.hs --- a/src/Rasa/Internal/Listeners.hs +++ b/src/Rasa/Internal/Listeners.hs @@ -1,100 +1,121 @@ -{-# LANGUAGE ExistentialQuantification, ScopedTypeVariables #-} +{-# language + GADTs + , ExistentialQuantification + , ScopedTypeVariables + , RankNTypes +#-} module Rasa.Internal.Listeners - ( Listener - , Listeners - , onEveryTrigger - , onEveryTrigger_ - , onNextEvent + ( dispatchEvent + , addListener + , addListener_ + , removeListener + + , dispatchBufEvent + , addBufListener + , addBufListener_ + , removeBufListener + + , Dispatcher + , ListenerId + , onInit - , beforeEveryEvent - , beforeEveryEvent_ - , beforeNextEvent + , dispatchInit + + , afterInit + , dispatchAfterInit + , beforeEveryRender , beforeEveryRender_ - , beforeNextRender + , dispatchBeforeRender + + , beforeEveryEvent + , beforeEveryEvent_ + , dispatchBeforeEvent + , onEveryRender , onEveryRender_ - , onNextRender + , dispatchOnRender + , afterEveryRender , afterEveryRender_ - , afterNextRender - , dispatchEvent + , dispatchAfterRender + , onExit - , removeListener - , matchingListeners + , dispatchExit + , onBufAdded + , onBufAdded_ + , dispatchBufAdded + , onEveryNewBuffer + , onEveryNewBuffer_ + , onBufTextChanged - ) where + , dispatchBufTextChanged + , onKeypress + , dispatchKeypress + , asyncEventProvider + , dispatchEventAsync + ) where + import Rasa.Internal.Action +import Rasa.Internal.Actions +import Rasa.Internal.BufAction import Rasa.Internal.Events -import Rasa.Internal.Editor -import Rasa.Internal.Range +import Rasa.Internal.Extensions import Control.Lens import Control.Monad -import Data.Dynamic -import Data.Foldable -import Data.Map hiding (filter) -import Unsafe.Coerce -import qualified Yi.Rope as Y +import Data.Default +import Data.Typeable +import Data.Maybe +import qualified Data.Map as M --- | Use this to dispatch an event of any type, any listeners which are listening for this event will be triggered --- with the provided event. Use this within an Action. -dispatchEvent :: Typeable a => a -> Action () -dispatchEvent evt = do - listeners' <- use listeners - traverse_ ($ evt) (matchingListeners listeners') +-- | A wrapper around event listeners so they can be stored in 'Listeners'. +data Listener where + Listener :: (Typeable eventType, Typeable result, Monoid result, HasExtMonad m) => TypeRep -> ListenerId -> (eventType -> m result) -> Listener --- | This is a helper which extracts and coerces a listener from its wrapper back into the proper event handler type. -getListener :: forall a. Listener -> (a -> Action ()) -getListener = coerce - where - coerce :: Listener -> (a -> Action ()) - coerce (Listener _ x) = unsafeCoerce x +instance Show Listener where + show (Listener rep (ListenerId n _) _) = "" -makeListener :: forall a b. Typeable a => (a -> Action b) -> Action (ListenerId, Listener) -makeListener listenerFunc = do - n <- nextListenerId <<+= 1 - let listenerId = ListenerId n (typeRep (Proxy :: Proxy a)) - listenerFunc' = void . listenerFunc - return (listenerId, Listener listenerId listenerFunc') +-- | An opaque reverence to a specific registered event-listener. +-- A ListenerId is used only to remove listeners later with 'Rasa.Internal.Listeners.removeListener'. +data ListenerId = + ListenerId Int TypeRep + deriving Show -extendListener :: Listener -> Action () -> Listener -extendListener (Listener listenerId listenerFunc) act = Listener listenerId (\a -> listenerFunc a >> act) +instance Eq ListenerId where + ListenerId a _ == ListenerId b _ = a == b +-- | A map of Event types to a list of listeners for that event +type Listeners = M.Map TypeRep [Listener] + +-- | Store the listeners in extensions +data LocalListeners = + LocalListeners Int Listeners + deriving Show + +instance Default LocalListeners where + def = LocalListeners 0 M.empty + -- | This extracts all event listeners from a map of listeners which match the type of the provided event. -matchingListeners :: forall a. Typeable a => Listeners -> [a -> Action ()] -matchingListeners listeners' = getListener <$> (listeners'^.at (typeRep (Proxy :: Proxy a))._Just) +matchingListeners :: forall eventType result m. (Typeable eventType, Typeable result, HasExtMonad m) => Listeners -> [eventType -> m result] +matchingListeners listeners = catMaybes $ (getListener :: Listener -> Maybe (eventType -> m result)) <$> (listeners^.at (typeRep (Proxy :: Proxy eventType))._Just) --- | This registers an event listener, as long as the listener is well-typed similar to this: --- --- @MyEventType -> Action ()@ then it will be triggered on all dispatched events of type @MyEventType@. --- It returns an ID which may be used with 'removeListener' to cancel the listener -onEveryTrigger :: forall a b. Typeable a => (a -> Action b) -> Action ListenerId -onEveryTrigger listenerFunc = do - (listenerId, listener) <- makeListener listenerFunc - listeners %= insertWith mappend (typeRep (Proxy :: Proxy a)) [listener] - return listenerId +-- | Extract the listener function from eventType listener +getListener :: Typeable expected => Listener -> Maybe expected +getListener (Listener _ _ x) = cast x -onEveryTrigger_ :: forall a b. Typeable a => (a -> Action b) -> Action () -onEveryTrigger_ = void . onEveryTrigger --- | This acts as 'onEveryTrigger' but listens only for the first event of a given type. -onNextEvent :: forall a b. Typeable a => (a -> Action b) -> Action () -onNextEvent listenerFunc = do - (listenerId, listener) <- makeListener listenerFunc - let selfCancellingListener = extendListener listener (removeListener listenerId) - listeners %= insertWith mappend (typeRep (Proxy :: Proxy a)) [selfCancellingListener] +-- | Trigger an 'Action' on a 'Keypress' +onKeypress :: (Keypress -> Action result) -> Action ListenerId +onKeypress actionF = addListener (void <$> actionF) --- | This removes a listener and prevents it from responding to any more events. -removeListener :: ListenerId -> Action () -removeListener hkIdA@(ListenerId _ typ) = - listeners.at typ._Just %= filter listenerMatches - where - listenerMatches (Listener hkIdB _) = hkIdA /= hkIdB +-- | Dispatch a 'Keypress' event. +dispatchKeypress :: Keypress -> Action () +dispatchKeypress = dispatchEvent -- | Registers an action to be performed during the Initialization phase. -- @@ -102,63 +123,72 @@ -- Though arbitrary actions may be performed in the configuration block; -- it's recommended to embed such actions in the onInit event listener -- so that all event listeners are registered before anything Actions occur. -onInit :: forall a. Action a -> Action () -onInit action = onNextEvent (const action :: Init -> Action a) +onInit :: Action result -> Action () +onInit action = void $ addListener (const (void action) :: Init -> Action ()) +-- | Dispatch the 'Init' action. +dispatchInit :: Action () +dispatchInit = dispatchEvent Init + +afterInit :: Action a -> Action () +afterInit action = void $ addListener (const (void action) :: AfterInit -> Action ()) + +-- | Dispatch the 'Init' action. +dispatchAfterInit :: Action () +dispatchAfterInit = dispatchEvent AfterInit + -- | Registers an action to be performed BEFORE each event phase. -beforeEveryEvent :: forall a. Action a -> Action ListenerId -beforeEveryEvent action = onEveryTrigger (const action :: BeforeEvent -> Action a) +beforeEveryEvent :: Action a -> Action ListenerId +beforeEveryEvent action = addListener (const (void action) :: BeforeEvent -> Action ()) -beforeEveryEvent_ :: forall a. Action a -> Action () +beforeEveryEvent_ :: Action a -> Action () beforeEveryEvent_ = void . beforeEveryEvent --- | Registers an action to be performed ONCE before only the NEXT event phase. -beforeNextEvent :: forall a. Action a -> Action () -beforeNextEvent action = onNextEvent (const action :: BeforeEvent -> Action a) +-- | Dispatch the 'BeforeEvent' action. +dispatchBeforeEvent :: Action () +dispatchBeforeEvent = dispatchEvent BeforeEvent -- | Registers an action to be performed BEFORE each render phase. -- -- This is a good spot to add information useful to the renderer -- since all actions have been performed. Only cosmetic changes should -- occur during this phase. -beforeEveryRender :: forall a. Action a -> Action ListenerId -beforeEveryRender action = onEveryTrigger (const action :: BeforeRender -> Action a) +beforeEveryRender :: Action a -> Action ListenerId +beforeEveryRender action = addListener (const (void action) :: BeforeRender -> Action ()) -beforeEveryRender_ :: forall a. Action a -> Action () +beforeEveryRender_ :: Action a -> Action () beforeEveryRender_ = void . beforeEveryRender --- | Registers an action to be performed ONCE before only the NEXT render phase. -beforeNextRender :: forall a. Action a -> Action () -beforeNextRender action = onNextEvent (const action :: BeforeRender -> Action a) +-- | Dispatch the 'BeforeRender' action. +dispatchBeforeRender :: Action () +dispatchBeforeRender = dispatchEvent BeforeRender -- | Registers an action to be performed during each render phase. -- -- This phase should only be used by extensions which actually render something. -onEveryRender :: forall a. Action a -> Action ListenerId -onEveryRender action = onEveryTrigger (const action :: OnRender -> Action a) +onEveryRender :: Action a -> Action ListenerId +onEveryRender action = addListener (const $ void action :: OnRender -> Action ()) -onEveryRender_ :: forall a. Action a -> Action () +onEveryRender_ :: Action a -> Action () onEveryRender_ = void . onEveryRender --- | Registers an action to be performed ONCE before only the NEXT render phase. --- --- This phase should only be used by extensions which actually render something. -onNextRender :: forall a. Action a -> Action () -onNextRender action = onNextEvent (const action :: OnRender -> Action a) +-- | Dispatch the 'OnRender' action. +dispatchOnRender :: Action () +dispatchOnRender = dispatchEvent OnRender -- | Registers an action to be performed AFTER each render phase. -- -- This is useful for cleaning up extension state that was registered for the -- renderer, but needs to be cleared before the next iteration. -afterEveryRender :: forall a. Action a -> Action ListenerId -afterEveryRender action = onEveryTrigger (const action :: AfterRender -> Action a) +afterEveryRender :: Action a -> Action ListenerId +afterEveryRender action = addListener (const $ void action :: AfterRender -> Action ()) -afterEveryRender_ :: forall a. Action a -> Action () +afterEveryRender_ :: Action a -> Action () afterEveryRender_ = void . afterEveryRender --- | Registers an action to be performed after the NEXT render phase. -afterNextRender :: forall a. Action a -> Action () -afterNextRender action = onNextEvent (const action :: AfterRender -> Action a) +-- | Dispatch the 'AfterRender' action. +dispatchAfterRender :: Action () +dispatchAfterRender = dispatchEvent AfterRender -- | Registers an action to be performed during the exit phase. -- @@ -166,21 +196,155 @@ -- allows an opportunity to do clean-up, kill any processes you've started, or -- save any data before the editor terminates. -onExit :: forall a. Action a -> Action () -onExit action = onNextEvent (const action :: Exit -> Action a) +onExit :: Action a -> Action () +onExit action = void $ addListener (const $ void action :: Exit -> Action ()) +-- | Dispatch the 'Exit' action. +dispatchExit :: Action () +dispatchExit = dispatchEvent Exit + -- | Registers an action to be performed after a new buffer is added. -- -- The supplied function will be called with a 'BufRef' to the new buffer, and the resulting 'Action' will be run. -onBufAdded :: forall a. (BufRef -> Action a) -> Action ListenerId -onBufAdded f = onEveryTrigger listener - where - listener (BufAdded bRef) = f bRef +onBufAdded :: (BufAdded -> Action result) -> Action ListenerId +onBufAdded actionF = addListener (void . actionF) +onBufAdded_ :: (BufAdded -> Action result) -> Action () +onBufAdded_ = void . onBufAdded + +-- | Run the given 'BufAction' over all new buffers +onEveryNewBuffer :: BufAction a -> Action ListenerId +onEveryNewBuffer bufAction = onBufAdded $ + \(BufAdded br) -> bufDo_ br bufAction + +onEveryNewBuffer_ :: BufAction a -> Action () +onEveryNewBuffer_ = void . onEveryNewBuffer + +-- | Dispatch the 'BufAdded' action. +dispatchBufAdded :: BufAdded -> Action () +dispatchBufAdded = dispatchEvent + -- | This is fired every time text in a buffer changes. -- -- The range of text which was altered and the new value of that text are provided inside a 'BufTextChanged' event. -onBufTextChanged :: forall a. (CrdRange -> Y.YiString -> Action a) -> Action ListenerId -onBufTextChanged f = onEveryTrigger listener - where - listener (BufTextChanged r newText) = f r newText +onBufTextChanged :: (BufTextChanged -> BufAction result) -> BufAction ListenerId +onBufTextChanged bufActionF = addBufListener (void . bufActionF) + +-- | Dispatch the 'BufBufTextChanged' action. +dispatchBufTextChanged :: BufTextChanged -> BufAction () +dispatchBufTextChanged = dispatchBufEvent + +-- | This is a type alias to make defining your functions for use with 'asyncEventProvider' easier; +-- It represents the function your event provider function will be passed to allow dispatching +-- events. Using this type requires the @RankNTypes@ language pragma. +type Dispatcher = forall event. Typeable event => event -> IO () + +-- | This allows long-running IO processes to provide Events to Rasa asyncronously. +-- +-- Don't let the type signature confuse you; it's much simpler than it seems. +-- +-- Let's break it down: +-- +-- Using the 'Dispatcher' type with asyncEventProvider requires the @RankNTypes@ language pragma. +-- +-- This type as a whole represents a function which accepts a 'Dispatcher' and returns an 'IO'; +-- the dispatcher itself accepts data of ANY 'Typeable' type and emits it as an event (see "Rasa.Internal.Events"). +-- +-- When you call 'asyncEventProvider' you pass it a function which accepts a @dispatch@ function as an argument +-- and then calls it with various events within the resulting 'IO'. +-- +-- Note that asyncEventProvider calls forkIO internally, so there's no need to do that yourself. +-- +-- Here's an example which fires a @Timer@ event every second. +-- +-- > {-# language RankNTypes #-} +-- > data Timer = Timer +-- > myTimer :: Dispatcher -> IO () +-- > myTimer dispatch = forever $ dispatch Timer >> threadDelay 1000000 +-- > +-- > myAction :: Action () +-- > myAction = onInit $ asyncEventProvider myTimer +asyncEventProvider :: (Dispatcher -> IO ()) -> Action () +asyncEventProvider asyncEventProv = + asyncActionProvider $ eventsToActions asyncEventProv + where + eventsToActions :: (Dispatcher -> IO ()) -> (Action () -> IO ()) -> IO () + eventsToActions aEventProv dispatcher = aEventProv (dispatcher . dispatchEvent) + + +-- | This function takes an IO which results in some Event, it runs the IO +-- asynchronously and dispatches the event +dispatchEventAsync :: Typeable event => IO event -> Action () +dispatchEventAsync ioEvent = dispatchActionAsync $ dispatchEvent <$> ioEvent + +-- | Event dispatcher generic over its monad +dispatchEventG :: forall m result eventType. (Monoid result, Typeable eventType, Typeable result, HasExtMonad m) => eventType -> m result +dispatchEventG evt = do + LocalListeners _ listeners <- getExt + results <- traverse ($ evt) (matchingListeners listeners :: [eventType -> m result]) + return (mconcat results :: result) + +-- | addListener which is generic over its monad +addListenerG :: forall result eventType m. (Typeable eventType, Typeable result, Monoid result, HasExtMonad m) => (eventType -> m result) -> m ListenerId +addListenerG lFunc = do + LocalListeners nextListenerId listeners <- getExt + let (listener, listenerId, eventType) = mkListener nextListenerId lFunc + newListeners = M.insertWith mappend eventType [listener] listeners + setExt $ LocalListeners (nextListenerId + 1) newListeners + return listenerId + where + mkListener :: forall event r. (Typeable event, Typeable r, Monoid r) => Int -> (event -> m r) -> (Listener, ListenerId, TypeRep) + mkListener n listenerFunc = + let list = Listener (typeOf listenerFunc) listId listenerFunc + listId = ListenerId n (typeRep (Proxy :: Proxy event)) + prox = typeRep (Proxy :: Proxy event) + in (list, listId, prox) + +-- | removeListener which is generic over its monad +removeListenerG :: HasExtMonad m => ListenerId -> m () +removeListenerG listenerId@(ListenerId _ eventType) = + overExt remover + where + remover (LocalListeners nextListenerId listeners) = + let newListeners = listeners & at eventType._Just %~ filter (notMatch listenerId) + in LocalListeners nextListenerId newListeners + notMatch idA (Listener _ idB _) = idA /= idB + +-- | Dispatches an event of any type. This should be used to define +-- your own custom event dispatchers (with more concrete types) which you can re-export. +-- You can collect results from all listeners if they were registered to return an @Action result@ +-- where @result@ is a Monoid (for example a list). +dispatchEvent :: forall result eventType. (Monoid result, Typeable eventType, Typeable result) => eventType -> Action result +dispatchEvent = dispatchEventG + +-- | This adds an event listener which listens for events of @eventType@ and will run the resulting +-- @Action result@ when triggered by some 'dispatchEvent'. +-- +-- This should primarily be used to create your own more specific addListener functions which you re-export. +addListener :: (Typeable eventType, Typeable result, Monoid result) => (eventType -> Action result) -> Action ListenerId +addListener = addListenerG + +addListener_ :: (Typeable eventType, Typeable result, Monoid result) => (eventType -> Action result) -> Action () +addListener_ = void . addListener + +-- | Removes the listener represented by the given ListenerId. +removeListener :: ListenerId -> Action () +removeListener = removeListenerG + +-- | Dispatches an event of any type to the BufAction's buffer. +-- See 'dispatchEvent' +dispatchBufEvent :: (Monoid result, Typeable eventType, Typeable result) => (eventType -> BufAction result) +dispatchBufEvent = dispatchEventG + +-- | Adds a listener to the BufAction's buffer. +-- See 'addListener' +addBufListener :: (Typeable eventType, Typeable result, Monoid result) => (eventType -> BufAction result) -> BufAction ListenerId +addBufListener = addListenerG + +addBufListener_ :: (Typeable eventType, Typeable result, Monoid result) => (eventType -> BufAction result) -> BufAction () +addBufListener_ = void . addBufListener + +-- | Removes a listener from the BufAction's buffer. +-- See 'removeListener' +removeBufListener :: ListenerId -> BufAction () +removeBufListener = removeListenerG diff --git a/src/Rasa/Internal/Range.hs b/src/Rasa/Internal/Range.hs --- a/src/Rasa/Internal/Range.hs +++ b/src/Rasa/Internal/Range.hs @@ -52,9 +52,12 @@ data Range a b = Range { _rStart :: a , _rEnd :: b - } deriving (Show, Eq) + } deriving (Eq) makeLenses ''Range +instance (Show a, Show b) => Show (Range a b) where + show (Range a b) = "(Range (start " ++ show a ++ ") (end " ++ show b ++ "))" + instance Bifunctor Range where bimap f g (Range a b) = Range (f a) (g b) @@ -75,8 +78,11 @@ data Coord' a b = Coord { _coordRow::a , _coordCol::b - } deriving (Show, Eq) + } deriving (Eq) makeLenses ''Coord' + +instance (Show a, Show b) => Show (Coord' a b) where + show (Coord a b) = "(Coord (row " ++ show a ++ ") (col " ++ show b ++ "))" -- | A type alias to 'Coord'' which specializes the types to integers. type Coord = Coord' Int Int diff --git a/src/Rasa/Internal/Styles.hs b/src/Rasa/Internal/Styles.hs new file mode 100644 --- /dev/null +++ b/src/Rasa/Internal/Styles.hs @@ -0,0 +1,93 @@ +{-# language + GeneralizedNewtypeDeriving +#-} +module Rasa.Internal.Styles + ( fg + , bg + , flair + , Color(..) + , Flair(..) + , Style(..) + , Styles + , addStyleProvider + , getStyles + ) where + +import Rasa.Internal.Range +import Rasa.Internal.BufAction +import Rasa.Internal.Listeners + +import Control.Applicative +import Data.Default + +-- | These represent the possible colors for 'fg' or 'bg'. +-- 'DefColor' represents the renderer's default color. +data Color = + Black + | Red + | Green + | Yellow + | Blue + | Magenta + | Cyan + | White + | DefColor + deriving (Show, Eq) + +-- | These represent the possible extra attributes which may be applied. +-- 'DefFlair' represents the renderer's default text attributes. +data Flair = + Standout + | Underline + | ReverseVideo + | Blink + | Dim + | Bold + | DefFlair + deriving (Show, Eq) + +-- | A container which holds a foreground color, background color, and a flair. +-- a 'Nothing' represents that we should not change that attribute. +newtype Style = Style (Maybe Color, Maybe Color, Maybe Flair) + deriving (Show, Eq) + +instance Default Style where + def = Style (Just DefColor, Just DefColor, Just DefFlair) + +-- | The monoid instance replaces any attributes which have a 'Just' in the new 'Style' +-- and persists any that are 'Nothing' in the new style (using 'Data.Alternative' for 'Data.Maybe') +instance Monoid Style where + Style (a, b, c) `mappend` Style (a', b', c') = Style (a' <|> a, b' <|> b, c' <|> c) + + mempty = Style (Nothing, Nothing, Nothing) + +type Styles = [Span CrdRange Style] +newtype StyleMap = + StyleMap Styles + deriving (Show, Eq, Monoid) + +instance Default StyleMap where + def = StyleMap [] + +-- | Create a new 'Style' with the given 'Color' as the foreground. +fg :: Color -> Style +fg a = Style (Just a, Nothing, Nothing) + +-- | Create a new 'Style' with the given 'Color' as the background. +bg :: Color -> Style +bg a = Style (Nothing, Just a, Nothing) + +-- | Create a new 'Style' with the given 'Flair' as its flair. +flair :: Flair -> Style +flair a = Style (Nothing, Nothing, Just a) + +data ComputeStyles = ComputeStyles + +-- | Pass this a 'BufAction' which computes styles based on the current buffer +-- and they'll be collected for the renderer. +addStyleProvider :: BufAction Styles -> BufAction ListenerId +addStyleProvider provider = addBufListener (const provider :: ComputeStyles -> BufAction Styles) + +-- | Collect all provided styles, this is useful for renderers. +getStyles :: BufAction Styles +getStyles = dispatchBufEvent ComputeStyles diff --git a/src/Rasa/Internal/Utility.hs b/src/Rasa/Internal/Utility.hs new file mode 100644 --- /dev/null +++ b/src/Rasa/Internal/Utility.hs @@ -0,0 +1,79 @@ +{-# language + FlexibleInstances +#-} +module Rasa.Internal.Utility + ( Width + , Height + , Renderable(..) + , RenderInfo(..) + , ScrollPos + , cropToViewport + , styleText + ) where + +import Rasa.Internal.ActionMonads +import Rasa.Internal.Editor +import Rasa.Internal.Actions +import Rasa.Internal.Styles +import Rasa.Internal.BufAction +import Rasa.Internal.Range + +import Control.Lens +import Data.Bifunctor + +import qualified Yi.Rope as Y + +type Width = Int +type Height = Int + +-- | RenderInfo is the data necessary to render something; it consists of a block of +-- text with its associated styles. It is a Monoid and can be appended with other 'RenderInfo's. +data RenderInfo = + RenderInfo Y.YiString Styles + +-- | Appends to RenderInfo by appending the text and styles while preserving +-- proper text/style alignment +instance Monoid RenderInfo where + mempty = RenderInfo mempty mempty + RenderInfo txtA stylesA `mappend` RenderInfo txtB stylesB = + RenderInfo + (txtA `mappend` txtB) + (mappend stylesA $ first (moveRange (sizeOf txtA)) <$> stylesB) + +-- | Represents how to render an entity +class Renderable r where + render :: Width -> Height -> ScrollPos -> r -> Action (Maybe RenderInfo) + +instance Renderable r => Renderable (Maybe r) where + render width height scrollPos (Just r) = render width height scrollPos r + render _ _ _ Nothing = return Nothing + +instance Renderable BufRef where + render _ height scrollPos bufRef = bufDo bufRef $ do + txt <- getText + styles <- getStyles + return $ cropToViewport height scrollPos (RenderInfo txt styles) + +instance Renderable Y.YiString where + render _ height scrollPos txt = return . Just $ cropToViewport height scrollPos (RenderInfo txt []) + +instance Renderable RenderInfo where + render _ _ _ r = return (Just r) + +type ScrollPos = Int + +-- | Crop text verticaly to only the visible portion according to viewport height and +-- scroll position. +cropToViewport :: Height -> ScrollPos -> RenderInfo -> RenderInfo +cropToViewport height scrollAmt (RenderInfo txt styles) = RenderInfo trimmedText adjustedStyles + where + adjustedStyles :: Styles + adjustedStyles = first adjustStylePositions <$> styles + adjustStylePositions :: CrdRange -> CrdRange + adjustStylePositions = both.coordRow -~ scrollAmt + trimmedText :: Y.YiString + trimmedText = Y.concat . take height . drop scrollAmt . Y.lines' $ txt + +-- | Add a style to some text resulting in a 'RenderInfo' +styleText :: Y.YiString -> Style -> RenderInfo +styleText txt style = RenderInfo txt [Span (Range (Coord 0 0) (sizeOf txt)) style] diff --git a/src/Rasa/Testing.hs b/src/Rasa/Testing.hs new file mode 100644 --- /dev/null +++ b/src/Rasa/Testing.hs @@ -0,0 +1,21 @@ +module Rasa.Testing ( + testBufAction + ) where + +import Rasa.Internal.Interpreters +import Rasa.Internal.Action +import Rasa.Internal.Actions +import Rasa.Internal.BufAction + +import Test.Hspec +import Control.Monad +import qualified Yi.Rope as Y + +testBufAction :: (Show a, Eq a) => String -> Y.YiString -> a -> BufAction a -> Spec +testBufAction description txt expectation bufAction = join . runIO $ + bootstrapAction $ do + ref <- addBuffer txt + mResult <- bufDo ref bufAction + case mResult of + Nothing -> error "(Err #75b72c) Buffer not found by BufRef" + Just res -> return $ it description (res `shouldBe` expectation) diff --git a/test/ArbitraryInstances.hs b/test/ArbitraryInstances.hs --- a/test/ArbitraryInstances.hs +++ b/test/ArbitraryInstances.hs @@ -1,11 +1,12 @@ {-# language ScopedTypeVariables, FlexibleInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module ArbitraryInstances where import qualified Data.Text as T import qualified Yi.Rope as Y import Test.QuickCheck -import Test.QuickCheck.Instances +import Test.QuickCheck.Instances () import Rasa.Internal.Range diff --git a/test/Rasa/Internal/BufActionsSpec.hs b/test/Rasa/Internal/BufActionsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Rasa/Internal/BufActionsSpec.hs @@ -0,0 +1,17 @@ +module Rasa.Internal.BufActionsSpec where + +import Test.Hspec + +import Rasa.Testing +import Rasa.Internal.Range +import Rasa.Internal.BufActions +import qualified Yi.Rope as Y + +sampleText :: Y.YiString +sampleText = "Testing line one\nshort line\n a long line " + +spec :: Spec +spec = + describe "getLineRange" $ + testBufAction "should get the range of a line" sampleText + (Just $ Range (Coord 1 0) (Coord 1 11)) (getLineRange 1) diff --git a/test/Rasa/Internal/RangeSpec.hs b/test/Rasa/Internal/RangeSpec.hs --- a/test/Rasa/Internal/RangeSpec.hs +++ b/test/Rasa/Internal/RangeSpec.hs @@ -2,13 +2,10 @@ import Test.Hspec import Test.Hspec.QuickCheck -import Test.QuickCheck.Instances -import ArbitraryInstances +import Test.QuickCheck.Instances () +import ArbitraryInstances () import Rasa.Internal.Range - -import qualified Yi.Rope as Y -import Control.Lens spec :: Spec spec = do diff --git a/test/Rasa/Internal/TextSpec.hs b/test/Rasa/Internal/TextSpec.hs --- a/test/Rasa/Internal/TextSpec.hs +++ b/test/Rasa/Internal/TextSpec.hs @@ -2,8 +2,8 @@ import Test.Hspec import Test.Hspec.QuickCheck -import Test.QuickCheck.Instances -import ArbitraryInstances +import Test.QuickCheck.Instances () +import ArbitraryInstances () import Rasa.Internal.Text