From c8cbee394f3763536fa41af3e51ca7bc7f482eed Mon Sep 17 00:00:00 2001 From: DavidLee18 Date: Fri, 28 Jun 2024 18:06:11 +0900 Subject: [PATCH] use some comonads --- packages.dhall | 11 ++++ spago.dhall | 2 + src/Data/Zipper.purs | 46 ++++++++++++++ src/Main.purs | 147 ++++++++++++++++++++++--------------------- 4 files changed, 133 insertions(+), 73 deletions(-) create mode 100644 src/Data/Zipper.purs diff --git a/packages.dhall b/packages.dhall index cbd9858..3bb6d97 100644 --- a/packages.dhall +++ b/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 + } diff --git a/spago.dhall b/spago.dhall index 6d64b56..756cd1b 100644 --- a/spago.dhall +++ b/spago.dhall @@ -10,12 +10,14 @@ , "either" , "halogen" , "integers" + , "lists" , "maybe" , "prelude" , "profunctor-lenses" , "quickcheck" , "read" , "strings" + , "transformers" , "tuples" , "typelevel-prelude" , "web-events" diff --git a/src/Data/Zipper.purs b/src/Data/Zipper.purs new file mode 100644 index 0000000..430b562 --- /dev/null +++ b/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 diff --git a/src/Main.purs b/src/Main.purs index e57476a..7cebcea 100644 --- a/src/Main.purs +++ b/src/Main.purs @@ -4,14 +4,13 @@ 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 @@ -19,13 +18,14 @@ 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 \ No newline at end of file +handleKey (Special _) _ = pure unit