use some comonads

packages.dhall

@@ -103,3 +103,14 @@ let upstream =
         sha256:1b7ca184d0912f929766a00dd1841a18b18513dd108c7fe3bda61769a1f2e5f2
 
 in  upstream
+with pairing =
+    { dependencies =
+        [ "free"
+        , "functors"
+        , "transformers"
+        ]
+    , repo =
+        "https://github.com/paf31/purescript-pairing.git"
+    , version =
+        "v5.1.0"  -- branch, tag, or commit hash
+    }

spago.dhall

@@ -10,12 +10,14 @@
   , "either"
   , "halogen"
   , "integers"
+  , "lists"
   , "maybe"
   , "prelude"
   , "profunctor-lenses"
   , "quickcheck"
   , "read"
   , "strings"
+  , "transformers"
   , "tuples"
   , "typelevel-prelude"
   , "web-events"

src/Data/Zipper.purs

@@ -0,0 +1,46 @@
+module Data.Zipper where
+
+import Prelude
+
+import Control.Comonad (class Comonad, class Extend)
+import Data.List.Lazy (List, Step(..), delete, elem, iterate, step, toUnfoldable, (:))
+import Data.Maybe (Maybe(..))
+
+data Zipper a = Zipper (List a) a (List a)
+
+derive instance Functor Zipper
+
+left :: forall a. Zipper a -> Zipper a
+left z@(Zipper ls a rs) = case step rs of
+    Nil -> z
+    Cons a' rs' -> Zipper (a:ls) a' rs'
+
+right :: forall a. Zipper a -> Zipper a
+right z@(Zipper ls a rs) = case step ls of
+    Nil -> z
+    Cons a' ls' -> Zipper ls' a' (a:rs)
+
+instance Extend Zipper where
+    extend f = map f <<< dup
+        where dup z = Zipper (iterate left z) z (iterate right z)
+
+instance Comonad Zipper where extract (Zipper _ a _) = a
+
+
+shiftLeft :: forall a. Int -> Zipper a -> Zipper a
+shiftLeft i z | i <= 0 = z
+              | otherwise = shiftLeft (i-1) (left z)
+
+shiftRight :: forall a. Int -> Zipper a -> Zipper a
+shiftRight i z | i <= 0 = z
+               | otherwise = shiftLeft (i-1) (right z)
+
+
+toArray :: forall a. Zipper a  -> Array a
+toArray (Zipper ls a rs) = toUnfoldable ls <> [a] <> toUnfoldable rs
+
+remove :: forall a. Eq a => a -> Zipper a -> Maybe (Zipper a)
+remove a (Zipper ls a' rs) | a == a' = Nothing
+                           | elem a ls = Just $ Zipper (delete a ls) a' rs
+                           | elem a rs = Just $ Zipper ls a' (delete a rs)
+                           | otherwise = Nothing

src/Main.purs

@@ -4,28 +4,28 @@ import Prelude
 
 import Control.Alt ((<|>))
 import Control.Comonad (extract)
+import Control.Comonad.Env (Env, env, runEnv, withEnv)
 import Data.Argonaut (Json, JsonDecodeError, decodeJson)
 import Data.Argonaut as Json
-import Data.Array (catMaybes, delete, head, null, sort)
 import Data.Array as Array
-import Data.Array.NonEmpty (NonEmptyArray, elemIndex, (!!), (:), last)
-import Data.Either (Either(..), either, hush)
+import Data.Either (Either, hush)
 import Data.Generic.Rep (class Generic)
-import Data.Gospel (Gospel(..), lookUpVerse, showTitle)
+import Data.Gospel (Gospel(..), showTitle)
 import Data.Gospel.Key (Key(..))
 import Data.Gospel.Key as Key
 import Data.Gospel.SpecialKey as SpecialKey
 import Data.Gospel.Verse (Verse)
 import Data.Gospel.Verse as Verse
 import Data.Lens (over)
 import Data.Lens.Record (prop)
-import Data.Maybe (Maybe(..), fromMaybe, maybe')
+import Data.List.Lazy as List
+import Data.Maybe (Maybe(..), fromMaybe, isJust, maybe')
 import Data.Show.Generic (genericShow)
 import Data.String (Pattern(..))
 import Data.String as String
 import Data.String.Read (read)
-import Data.Tuple (fst)
-import Data.Tuple.Nested (type (/\), (/\))
+import Data.Tuple.Nested ((/\))
+import Data.Zipper (Zipper(..), left, right, shiftLeft, shiftRight)
 import Effect (Effect)
 import Effect.Aff (launchAff_)
 import Effect.Class (class MonadEffect, liftEffect)
@@ -58,8 +58,8 @@ instance Show Route where show = genericShow
 type State =
     { blind :: Boolean
     , gospels :: Array Gospel
-    , position :: Maybe (Gospel /\ (Either String Verse))
-    , queue :: Array Gospel
+    , position :: Maybe (Zipper Verse)
+    , queue :: Env Int (Array Gospel)
     , route :: Route
     , subId :: Maybe SubscriptionId
     , textSize :: Int
@@ -69,7 +69,7 @@ defaultState :: State
 defaultState = { blind: false
                , gospels: []
                , position: Nothing
-               , queue: []
+               , queue: env 0 []
                , route: Home
                , subId: Nothing
                , textSize: 70
@@ -95,7 +95,7 @@ main = do
         void $ runUI mainComponent gospels body
 
 mainComponent :: forall query output m. MonadEffect m => Component query (Array (Either JsonDecodeError Gospel)) output m
-mainComponent = mkComponent { initialState: \eithers -> defaultState { gospels = sort $ catMaybes $ hush <$> eithers }
+mainComponent = mkComponent { initialState: \eithers -> defaultState { gospels = Array.sort $ Array.catMaybes $ hush <$> eithers }
                             , render
                             , eval: mkEval $ defaultEval { handleAction = handleAction }
                             }
@@ -105,14 +105,14 @@ render { gospels, queue, route: Home } = HH.div_ [ HH.h3_ [ HH.text "GospelSub i
                                                  , HH.span_ [ HH.text "Gospels" ]
                                                  , md_list [] $ Array.intersperse (md_divider []) $ map gospelView gospels
                                                  , HH.span_ [ HH.text "Queue" ]
-                                                 , md_list [] $ Array.intersperse (md_divider []) $ map queueItemView queue
-                                                 , md_filled_button ([ onClick $ \_ -> RouteTo Display ] <> if null queue then [ disabled ] else []) [ HH.text "Display", md_icon (IconName "slideshow") ]
+                                                 , md_list [] $ Array.intersperse (md_divider []) $ map queueItemView $ extract queue
+                                                 , md_filled_button ([ onClick $ \_ -> RouteTo Display ] <> if Array.null $ extract queue then [ disabled ] else []) [ HH.text "Display", md_icon (IconName "slideshow") ]
                                                  ]
 render { blind, position, route: Display, textSize } = HH.div_ [ HH.h2 [ style $ "font-size: " <> show textSize <> "px;" ] if blind then [] else fromMaybe [ HH.text "Loading Gospels..." ] titleOrVerse ]
-    where titleOrVerse = Array.intersperse HH.br_ <<< map HH.text <<< String.split (Pattern "\\n") <<< either identity Verse.string <<< extract <$> position
+    where titleOrVerse = Array.intersperse HH.br_ <<< map HH.text <<< String.split (Pattern "\\n") <<< Verse.string <<< extract <$> position
 
 gospelView :: forall w. Gospel -> HTML w Action
-gospelView g = md_list_item [] [ HH.span_ [ HH.text $ showTitle g ] 
+gospelView g = md_list_item [] [ HH.span_ [ HH.text $ showTitle g ]
                                , md_outlined_icon_button [ onClick $ \_ -> AddtoQueue g ] [ md_icon (IconName "add_circle_outline") ]
                                ]
 
@@ -136,83 +136,84 @@ handleAction (Log json) = Console.log $ Json.stringify json
 handleAction (RouteTo Display) = do
     win <- liftEffect window
     subscribe' \sid -> eventListener keyup (toEventTarget win) (map (HandleKeyEvent sid) <<< KE.fromEvent)
-    modify_ \st -> st { position = positionFromGospel <$> head (_.queue st), route = Display }
+    modify_ \st -> st { position = let i /\ qs = runEnv st.queue in positionFromGospel <$> qs Array.!! i, route = Display }
 handleAction (RouteTo route) = do
     sid <- gets _.subId
     maybe' pure unsubscribe sid
     modify_ _ { route = route, subId = Nothing }
-handleAction (AddtoQueue g) = modify_ $ over (prop (Proxy :: Proxy "queue")) \q -> if Array.elem g q then q else q <> [g]
-handleAction (RemovefromQueue g) = modify_ $ over (prop (Proxy :: Proxy "queue")) (delete g)
+handleAction (AddtoQueue g) = modify_ $ over (prop (Proxy :: Proxy "queue")) (map (insertUnique g))
+handleAction (RemovefromQueue g) = modify_ $ over (prop (Proxy :: Proxy "queue")) (map (Array.delete g))
 handleAction (QueueUp g) = do
-    q <- gets _.queue
-    let newQueue = do
-            i <- Array.elemIndex g q
-            let { before, after } = Array.splitAt i q
-            let newBefore = Array.dropEnd 1 before <> [g] <> Array.takeEnd 1 before
-            let newAfter = Array.drop 1 after
-            pure $ newBefore <> newAfter
-    modify_ _ { queue = fromMaybe q newQueue }
+    i /\ q <- runEnv <$> gets _.queue
+    let newQueue = let
+                        { before, after } = Array.splitAt i q
+                        newBefore = Array.dropEnd 1 before <> [g] <> Array.takeEnd 1 before
+                        newAfter = Array.drop 1 after
+                in newBefore <> newAfter
+    modify_ _ { queue = env (i-1) newQueue }
 handleAction (QueueDown g) = do
-    q <- gets _.queue
-    let newQueue = do
-            i <- Array.elemIndex g q
-            let { before, after } = Array.splitAt i q
-            let newAfter = Array.take 1 (Array.drop 1 after) <> [g] <> Array.drop 2 after
-            pure $ before <> newAfter
-    modify_ _ { queue = fromMaybe q newQueue }
-
-positionFromGospel :: forall t63. Gospel -> Gospel /\ (Either String t63)
-positionFromGospel g = g /\ (Left $ showTitle g)
-
-toNEArray :: Gospel -> NonEmptyArray (Either String Verse)
-toNEArray g@(Hymn { lyrics }) = (Left $ showTitle g) : (Right <$> lyrics)
-toNEArray g@(Gospel { lyrics }) = (Left $ showTitle g) : (Right <$> lyrics)
-
-verseOnIndex :: (Int -> Int) -> Gospel /\ Either String Verse -> Maybe (Either String Verse)
-verseOnIndex f (g /\ v) = do
-    let es = toNEArray g
-    i <- elemIndex v es
-    es !! f i
-
-verseOnArray :: (Int -> NonEmptyArray (Either String Verse) -> Maybe (Either String Verse)) -> Gospel /\ Either String Verse -> Maybe (Either String Verse)
-verseOnArray f (g /\ v) = do
-    let es = toNEArray g
-    i <- elemIndex v es
-    f i es
-
-mapPosition :: forall m. Monad m => (Gospel /\ Either String Verse -> m (Either String Verse)) -> m (Gospel /\ (Either String Verse)) -> m (Gospel /\ (Either String Verse))
-mapPosition f p = (/\) <$> (fst <$> p) <*> (f =<< p)
-
-gospelOnIndex :: (Int -> Int) -> Gospel -> Array Gospel -> Maybe Gospel
-gospelOnIndex f g gs = do
-    i <- Array.elemIndex g gs
-    gs Array.!! f i
+    i /\ q <- runEnv <$> gets _.queue
+    let newQueue = let
+                    { before, after } = Array.splitAt i q
+                    newAfter = Array.take 1 (Array.drop 1 after) <> [g] <> Array.drop 2 after
+                in before <> newAfter
+    modify_ _ { queue = env (i+1) newQueue }
+
+insertUnique :: forall a. Eq a => a -> Array a -> Array a
+insertUnique a as | Array.elem a as = as
+                  | otherwise = a Array.: as
+
+positionFromGospel :: Gospel -> Zipper Verse
+positionFromGospel g@(Hymn { lyrics }) = Zipper List.nil (Verse.Verse $ showTitle g) (List.fromFoldable lyrics)
+positionFromGospel g@(Gospel { lyrics }) = Zipper List.nil (Verse.Verse $ showTitle g) (List.fromFoldable lyrics)
+
+gotoFirst :: forall a. Zipper a -> Zipper a
+gotoFirst z@(Zipper ls _ _) | List.null ls = z
+                            | otherwise = gotoFirst (right z)
+
+gotoLast :: forall a. Zipper a -> Zipper a
+gotoLast z@(Zipper _ _ rs) | List.null rs = z
+                           | otherwise = gotoLast (left z)
+
+findVerse :: Key.Key -> Zipper Verse -> Zipper Verse
+findVerse k z@(Zipper ls a rs) | isJust $ Verse.keyVerse k a = z
+                               | otherwise = case List.findIndex (isJust <<< Verse.keyVerse k) ls of
+                                    Just i -> shiftRight i z
+                                    Nothing -> case List.findIndex (isJust <<< Verse.keyVerse k) rs of
+                                        Just j -> shiftLeft j z
+                                        Nothing -> z
+
+nth :: forall a. Int -> Zipper a -> Maybe a
+nth i (Zipper ls a rs) | List.length ls == i = Just a
+                       | otherwise = ls List.!! i <|> rs List.!! (i - List.length ls)
 
 handleKey :: forall slots output m. Key.Key -> SubscriptionId -> HalogenM State Action slots output m Unit
 handleKey (Key '0') _ = modify_ $ over (prop (Proxy :: Proxy "blind")) not
-handleKey (Key '/') _ = modify_ $ over (prop (Proxy :: Proxy "position")) \pos -> mapPosition (verseOnIndex \_ -> 0) pos <|> pos
-handleKey (Key '\\') _ = modify_ $ over (prop (Proxy :: Proxy "position")) \pos -> mapPosition (verseOnArray $ \_ -> Just <<< last) pos <|> pos
+handleKey (Key '/') _ = modify_ $ over (prop (Proxy :: Proxy "position")) (map gotoFirst)
+handleKey (Key '\\') _ = modify_ $ over (prop (Proxy :: Proxy "position")) (map gotoLast)
 handleKey (Key ',') _ = do
     q <- gets _.queue
-    pos <- gets _.position
-    let newPos = pos >>= \(g /\ _) -> positionFromGospel <$> gospelOnIndex (_ - 1) g q
-    modify_ _ { position = newPos <|> pos }
+    let newQ = withEnv (\i -> min (Array.length $ extract q) (i+1)) q
+    let i /\ qs = runEnv newQ
+    let newPos = positionFromGospel <$> qs Array.!! i
+    modify_ _ { position = newPos, queue = newQ }
 handleKey (Key '.') _ = do
     q <- gets _.queue
-    pos <- gets _.position
-    let newPos = pos >>= \(g /\ _) -> positionFromGospel <$> gospelOnIndex (_ + 1) g q
-    modify_ _ { position = newPos <|> pos }
-handleKey (Key c) _ = modify_ $ over (prop (Proxy :: Proxy "position")) \pos -> mapPosition (\(g /\ _) -> Right <$> lookUpVerse (Key c) g) pos <|> pos
+    let newQ = withEnv (\i -> max 0 (i-1)) q
+    let i /\ qs = runEnv newQ
+    let newPos = positionFromGospel <$> qs Array.!! i
+    modify_ _ { position = newPos, queue = newQ }
+handleKey (Key c) _ = modify_ $ over (prop (Proxy :: Proxy "position")) (map (findVerse (Key c)))
 handleKey (Special SpecialKey.Esc) sid = do
     unsubscribe sid
     modify_ _ { route = Home, subId = Nothing }
 handleKey (Special SpecialKey.UpArrow) _ = modify_ $ over (prop (Proxy :: Proxy "textSize")) (_ + 5)
 handleKey (Special SpecialKey.DownArrow) _ = modify_ $ over (prop (Proxy :: Proxy "textSize")) (\i -> max (i - 5) 5)
-handleKey (Special SpecialKey.LeftArrow) _ = modify_ $ over (prop (Proxy :: Proxy "position")) \pos -> mapPosition (verseOnIndex (_ - 1)) pos <|> pos
-handleKey (Special SpecialKey.RightArrow) _ = modify_ $ over (prop (Proxy :: Proxy "position")) \pos -> mapPosition (verseOnIndex (_ + 1)) pos <|> pos
+handleKey (Special SpecialKey.LeftArrow) _ = modify_ $ over (prop (Proxy :: Proxy "position")) (map right)
+handleKey (Special SpecialKey.RightArrow) _ = modify_ $ over (prop (Proxy :: Proxy "position")) (map left)
 handleKey (Special (SpecialKey.AltKey n)) _ = do
     q <- gets _.queue
     pos <- gets _.position
-    let newPos = pos >>= \(g /\ _) -> positionFromGospel <$> gospelOnIndex (\_ -> n) g q
+    let newPos = positionFromGospel <$> extract q Array.!! (n-1)
     modify_ _ { position = newPos <|> pos }
-handleKey (Special _) _ = pure unit
+handleKey (Special _) _ = pure unit