packages feed

rasa 0.1.9 → 0.1.10

raw patch · 24 files changed

+1195/−718 lines, 24 filesdep +profunctorsdep ~rasa

Dependencies added: profunctors

Dependency ranges changed: rasa

Files

README.md view
@@ -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)!
rasa.cabal view
@@ -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
src/Rasa.hs view
@@ -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
src/Rasa/Ext.hs view
@@ -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
src/Rasa/Internal/Action.hs view
@@ -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
+ src/Rasa/Internal/ActionMonads.hs view
@@ -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 ()
src/Rasa/Internal/Actions.hs view
@@ -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
− src/Rasa/Internal/Async.hs 
@@ -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
src/Rasa/Internal/BufAction.hs view
@@ -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
+ src/Rasa/Internal/BufActions.hs view
@@ -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
src/Rasa/Internal/Buffer.hs view
@@ -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 = "<Buffer {text:" ++ show (b^..text . to (Y.take 30)) ++ "...,\n"-           ++ "exts: " ++ show (b^.bufExts) ++ "}>\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     }
src/Rasa/Internal/Editor.hs view
@@ -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     }
src/Rasa/Internal/Events.hs view
@@ -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)-
src/Rasa/Internal/Extensions.hs view
@@ -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
+ src/Rasa/Internal/Interpreters.hs view
@@ -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
src/Rasa/Internal/Listeners.hs view
@@ -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 _) _) = "<Listener #" ++ show n ++ ", " ++ show rep ++ ">" -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
src/Rasa/Internal/Range.hs view
@@ -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
+ src/Rasa/Internal/Styles.hs view
@@ -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
+ src/Rasa/Internal/Utility.hs view
@@ -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]
+ src/Rasa/Testing.hs view
@@ -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)
test/ArbitraryInstances.hs view
@@ -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
+ test/Rasa/Internal/BufActionsSpec.hs view
@@ -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)
test/Rasa/Internal/RangeSpec.hs view
@@ -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
test/Rasa/Internal/TextSpec.hs view
@@ -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