diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2025 Leo Orpilla III + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/brick-calendar.cabal b/brick-calendar.cabal new file mode 100644 --- /dev/null +++ b/brick-calendar.cabal @@ -0,0 +1,72 @@ +cabal-version: 3.0 +name: brick-calendar +version: 0.1.0.0 +synopsis: Calendar widget for the Brick TUI library +description: A library providing a month calendar widget for Brick-based terminal user interfaces +homepage: https://github.com/ldgrp/brick-calendar +bug-reports: https://github.com/ldgrp/brick-calendar/issues +license: MIT +license-file: LICENSE +author: Leo Orpilla III +maintainer: leo@ldgrp.me +category: User Interfaces, Console, TUI +build-type: Simple + +source-repository head + type: git + location: https://github.com/ldgrp/brick-calendar.git + branch: main + +library + hs-source-dirs: src + exposed-modules: Brick.Widgets.Calendar + other-modules: Brick.Widgets.Calendar.Internal.Core + ,Brick.Widgets.Calendar.Internal.Month + ,Brick.Widgets.Calendar.Internal.Utils + ,Brick.Widgets.Calendar.Internal.Actions + build-depends: base >= 4.11 && < 5 + ,brick >= 2.8.3 && < 2.9 + ,vty >= 6.4 && < 6.5 + ,time >= 1.12.2 && < 1.13 + ,text >= 2.0.2 && < 2.1 + ,vector >= 0.13.2 && < 0.14 + ,microlens >= 0.4.14 && < 0.5 + ,microlens-th >= 0.4.3 && < 0.5 + default-language: Haskell2010 + ghc-options: -Wall + +test-suite brick-calendar-tests + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-depends: base >= 4.11 && < 5 + ,brick-calendar + ,brick >= 2.8.3 && < 2.9 + ,vty >= 6.4 && < 6.5 + ,time >= 1.12.2 && < 1.13 + ,hspec + default-language: Haskell2010 + ghc-options: -Wall + +executable calendar-demo + hs-source-dirs: programs + main-is: CalendarDemo.hs + build-depends: base >= 4.11 && < 5 + ,brick-calendar + ,brick >= 2.8.3 && < 2.9 + ,microlens-platform >= 0.4.4 && < 0.5 + ,time >= 1.12.2 && < 1.13 + ,vty >= 6.4 && < 6.5 + default-language: Haskell2010 + ghc-options: -Wall -threaded + +executable simple-demo + hs-source-dirs: programs + main-is: SimpleDemo.hs + build-depends: base >= 4.11 && < 5 + ,brick-calendar + ,brick >= 2.8.3 && < 2.9 + ,time >= 1.12.2 && < 1.13 + ,vty >= 6.4 && < 6.5 + default-language: Haskell2010 + ghc-options: -Wall -threaded diff --git a/programs/CalendarDemo.hs b/programs/CalendarDemo.hs new file mode 100644 --- /dev/null +++ b/programs/CalendarDemo.hs @@ -0,0 +1,186 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Brick +import Brick.Widgets.Core +import Brick.Widgets.Border +import qualified Brick.Widgets.Center as C +import Brick.Widgets.Calendar +import qualified Brick.AttrMap as A +import qualified Graphics.Vty as V +import Data.Time +import Control.Monad +import System.IO +import Lens.Micro.Platform + +-- | Data type to identify our widgets +data Name = Calendar1 + deriving (Eq, Ord, Show) + +-- | App state +newtype AppState = AppState + { calendar :: CalendarState + } + +-- | Lens for the calendar field of AppState +calendarL :: Lens' AppState CalendarState +calendarL = lens calendar (\s c -> s { calendar = c }) + +-- | Main app definition +app :: App AppState e CalendarResource +app = App + { appDraw = drawUI + , appChooseCursor = showFirstCursor + , appHandleEvent = handleEvent + , appStartEvent = return () + , appAttrMap = const defaultCalendarAttrMap + } + +-- | Initialize the app state +initialState :: IO AppState +initialState = do + today <- utctDay <$> getCurrentTime + let (year, month, _) = toGregorian today + let calConfig = defaultCalendarConfig + { _showDayLabels = True + , _dayLabelStyle = DistinctInitials + , _outsideMonthDisplay = ShowDimmed + , _weekStart = Sunday + } + return AppState + { calendar = CalendarState year month (Just today) calConfig + } + +-- | Draw the UI +drawUI :: AppState -> [Widget CalendarResource] +drawUI s = [C.center ((border (padAll 1 ui) <=> config) <+> hLimit 40 help)] + where + config = vBox + [ + displayConfig (calendar s) + ] + ui = + padAll 1 $ renderCalendar (calendar s) + help = vBox + [ str "Controls" + , hBorder + , str "Navigation:" + , str "arrow keys / hjkl - move selection" + , str "[] / HL - previous / next month" + , str "{} / JK - previous / next year" + , hBorder + , str "Settings:" + , str "d - toggle day labels" + , str "t - cycle label style" + , str "o - cycle outside days" + , str "w - toggle week start" + , hBorder + , str "Actions:" + , str "Enter / Esc / q - select date and exit" + ] + +-- | Display the current configuration +displayConfig :: CalendarState -> Widget n +displayConfig s = + let config = calConfig s + weekStartText = show (config ^. weekStart) + labelStyleText = case config ^. dayLabelStyle of + SingleChar -> "Single char" + DoubleChar -> "Double char" + DistinctInitials -> "Thursday as Th" + showLabelsText = if config ^. showDayLabels then "Show" else "Hide" + outsideText = case config ^. outsideMonthDisplay of + Hide -> "Hide" + ShowDimmed -> "Show dimmed" + ShowNormal -> "Show normal" + selectedText = case calSelectedDay s of + Nothing -> "None" + Just day -> showGregorian day + in withAttr (attrName "config") $ + vBox [ str $ "Week starts on: " ++ weekStartText + , str $ "Day label style: " ++ labelStyleText + , str $ "Day labels: " ++ showLabelsText + , str $ "Outside month days: " ++ outsideText + , str $ "Selected day: " ++ selectedText + ] + +-- | Handle events +handleEvent :: BrickEvent CalendarResource e -> EventM CalendarResource AppState () +handleEvent (VtyEvent (V.EvKey V.KEsc [])) = halt +handleEvent (VtyEvent (V.EvKey (V.KChar 'q') [])) = halt +handleEvent (VtyEvent (V.EvKey V.KEnter [])) = halt + +-- Toggle day labels +handleEvent (VtyEvent (V.EvKey (V.KChar 'd') [])) = do + zoom calendarL $ do + cal <- get + let config = calConfig cal + modify $ \s -> s { calConfig = config & showDayLabels %~ not } + +-- Cycle day label style +handleEvent (VtyEvent (V.EvKey (V.KChar 't') [])) = do + zoom calendarL $ do + cal <- get + let config = calConfig cal + newStyle = case config ^. dayLabelStyle of + SingleChar -> DoubleChar + DoubleChar -> DistinctInitials + DistinctInitials -> SingleChar + modify $ \s -> s { calConfig = config & dayLabelStyle .~ newStyle } + +-- Cycle outside month display +handleEvent (VtyEvent (V.EvKey (V.KChar 'o') [])) = do + zoom calendarL $ do + cal <- get + let config = calConfig cal + newOutside = case config ^. outsideMonthDisplay of + Hide -> ShowDimmed + ShowDimmed -> ShowNormal + ShowNormal -> Hide + modify $ \s -> s { calConfig = config & outsideMonthDisplay .~ newOutside } + +-- Toggle week start +handleEvent (VtyEvent (V.EvKey (V.KChar 'w') [])) = do + zoom calendarL $ do + cal <- get + let config = calConfig cal + newStart = case config ^. weekStart of + Sunday -> Monday + Monday -> Sunday + _ -> error "Not implemented" + modify $ \s -> s { calConfig = config & weekStart .~ newStart } + +-- Handle calendar keyboard events +handleEvent (VtyEvent (V.EvKey V.KUp [])) = calendarL %= moveUp +handleEvent (VtyEvent (V.EvKey V.KDown [])) = calendarL %= moveDown +handleEvent (VtyEvent (V.EvKey V.KLeft [])) = calendarL %= moveLeft +handleEvent (VtyEvent (V.EvKey V.KRight [])) = calendarL %= moveRight +handleEvent (VtyEvent (V.EvKey (V.KChar '[') [])) = calendarL %= setMonthBefore +handleEvent (VtyEvent (V.EvKey (V.KChar ']') [])) = calendarL %= setMonthAfter +handleEvent (VtyEvent (V.EvKey (V.KChar '{') [])) = calendarL %= setYearBefore +handleEvent (VtyEvent (V.EvKey (V.KChar '}') [])) = calendarL %= setYearAfter + +-- Handle vim-like navigation +handleEvent (VtyEvent (V.EvKey (V.KChar 'h') [])) = calendarL %= moveLeft +handleEvent (VtyEvent (V.EvKey (V.KChar 'j') [])) = calendarL %= moveDown +handleEvent (VtyEvent (V.EvKey (V.KChar 'k') [])) = calendarL %= moveUp +handleEvent (VtyEvent (V.EvKey (V.KChar 'l') [])) = calendarL %= moveRight +handleEvent (VtyEvent (V.EvKey (V.KChar 'H') [])) = calendarL %= setMonthBefore +handleEvent (VtyEvent (V.EvKey (V.KChar 'L') [])) = calendarL %= setMonthAfter +handleEvent (VtyEvent (V.EvKey (V.KChar 'J') [])) = calendarL %= setYearBefore +handleEvent (VtyEvent (V.EvKey (V.KChar 'K') [])) = calendarL %= setYearAfter +handleEvent _ = return () + +-- | Main function +main :: IO () +main = do + -- Ensure unicode support + hSetEncoding stdout utf8 + + -- Run the app + s <- initialState + finalState <- defaultMain app s + case calSelectedDay $ calendar finalState of + Just day -> putStrLn $ "Selected date: " ++ showGregorian day + Nothing -> putStrLn "No date selected" diff --git a/programs/SimpleDemo.hs b/programs/SimpleDemo.hs new file mode 100644 --- /dev/null +++ b/programs/SimpleDemo.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Brick +import Brick.Widgets.Border +import qualified Brick.Widgets.Center as C +import Brick.Widgets.Calendar +import qualified Brick.AttrMap as A +import qualified Graphics.Vty as V +import Data.Time +import Control.Monad +import System.IO + +-- App state with calendar +newtype AppState = AppState + { calendar :: CalendarState + } + +-- Initialize the app state +mkCalendarState :: Day -> CalendarState +mkCalendarState day = + let (year, month, _) = toGregorian day + config = defaultCalendarConfig + { _showDayLabels = True + , _dayLabelStyle = DistinctInitials + , _outsideMonthDisplay = ShowDimmed + , _weekStart = Sunday + } + in CalendarState year month (Just day) config + +-- Main app definition +app :: App AppState e CalendarResource +app = App + { appDraw = drawUI + , appChooseCursor = showFirstCursor + , appHandleEvent = handleEvent + , appStartEvent = return () + , appAttrMap = const defaultCalendarAttrMap + } + +-- Draw the UI +drawUI :: AppState -> [Widget CalendarResource] +drawUI s = [C.center $ border $ padAll 1 $ renderCalendar (calendar s)] + +-- Handle events +handleEvent :: BrickEvent CalendarResource e -> EventM CalendarResource AppState () +handleEvent (VtyEvent (V.EvKey V.KEsc [])) = halt +handleEvent (VtyEvent (V.EvKey (V.KChar 'q') [])) = halt +handleEvent (VtyEvent (V.EvKey V.KUp [])) = + modify $ \s -> s { calendar = moveUp (calendar s) } +handleEvent (VtyEvent (V.EvKey V.KDown [])) = + modify $ \s -> s { calendar = moveDown (calendar s) } +handleEvent (VtyEvent (V.EvKey V.KLeft [])) = + modify $ \s -> s { calendar = moveLeft (calendar s) } +handleEvent (VtyEvent (V.EvKey V.KRight [])) = + modify $ \s -> s { calendar = moveRight (calendar s) } +handleEvent (VtyEvent (V.EvKey (V.KChar '[') [])) = + modify $ \s -> s { calendar = setMonthBefore (calendar s) } +handleEvent (VtyEvent (V.EvKey (V.KChar ']') [])) = + modify $ \s -> s { calendar = setMonthAfter (calendar s) } +handleEvent (VtyEvent (V.EvKey (V.KChar '{') [])) = + modify $ \s -> s { calendar = setYearBefore (calendar s) } +handleEvent (VtyEvent (V.EvKey (V.KChar '}') [])) = + modify $ \s -> s { calendar = setYearAfter (calendar s) } +handleEvent _ = return () + +-- Main function +main :: IO () +main = do + -- Ensure unicode support + hSetEncoding stdout utf8 + + -- Get today's date and create initial state + today <- utctDay <$> getCurrentTime + let initialState = AppState { calendar = mkCalendarState today } + + -- Run the app + finalState <- defaultMain app initialState + + -- Print the selected date when the app exits + case calSelectedDay $ calendar finalState of + Just day -> putStrLn $ "Selected date: " ++ showGregorian day + Nothing -> putStrLn "No date selected" diff --git a/src/Brick/Widgets/Calendar.hs b/src/Brick/Widgets/Calendar.hs new file mode 100644 --- /dev/null +++ b/src/Brick/Widgets/Calendar.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | This module provides a month calendar widget for Brick applications. +-- +-- == Usage +-- +-- The widget provides: +-- +-- * A render function to display the calendar +-- * A set of actions for navigation (moveUp, moveDown, etc.) +-- * Configuration options +-- +-- Applications should connect the provided actions to keyboard events in their event handlers. +-- Common navigation patterns include: +-- +-- * Arrow keys: Use moveUp, moveDown, moveLeft, moveRight to navigate between days +-- * Month navigation: Use setMonthBefore, setMonthAfter to change months +-- * Year navigation: Use setYearBefore, setYearAfter to change years +-- +-- When a navigation action is applied and no day is selected, the first day of the current month will be selected. +-- When navigating between days, if moving to a date outside the current month, the view will automatically +-- shift to that month. +module Brick.Widgets.Calendar + ( -- * Render + renderCalendar + , CalendarState(..) + + -- * Actions + , moveUp + , moveDown + , moveLeft + , moveRight + , setMonthBefore + , setMonthAfter + , setYearBefore + , setYearAfter + + -- * Configuration + , CalendarConfig(..) + , DayLabelStyle(..) + , OutsideMonthDisplay(..) + , defaultCalendarConfig + + -- * Lenses + , weekStart + , dayLabelStyle + , showDayLabels + , outsideMonthDisplay + + + -- * Resource name + , CalendarResource(..) + + -- * Utilities + , getFirstDayOfMonth + , getDayLabel + , getMonthLabel + , getWeekDayLabels + , formatDate + , defaultCalendarAttrMap + ) where + +import qualified Brick.AttrMap as A +import qualified Graphics.Vty as V +import Brick.Util (fg) + +import Brick.Widgets.Calendar.Internal.Actions +import Brick.Widgets.Calendar.Internal.Core +import Brick.Widgets.Calendar.Internal.Month +import Brick.Widgets.Calendar.Internal.Utils + +-- | Attribute map for calendar widgets. +defaultCalendarAttrMap :: A.AttrMap +defaultCalendarAttrMap = A.attrMap V.defAttr + [ (A.attrName "calendar.day", fg V.white) + , (A.attrName "calendar.day" <> A.attrName "selected", fg V.black `V.withBackColor` V.blue) + , (A.attrName "calendar.outsideMonth", fg V.brightBlack) + , (A.attrName "calendar.outsideMonth" <> A.attrName "selected", fg V.black `V.withBackColor` V.blue) + , (A.attrName "calendar.hidden", V.currentAttr) + , (A.attrName "calendar.nav", fg V.blue) + , (A.attrName "calendar.header", V.defAttr `V.withStyle` V.bold) + ] diff --git a/src/Brick/Widgets/Calendar/Internal/Actions.hs b/src/Brick/Widgets/Calendar/Internal/Actions.hs new file mode 100644 --- /dev/null +++ b/src/Brick/Widgets/Calendar/Internal/Actions.hs @@ -0,0 +1,79 @@ +module Brick.Widgets.Calendar.Internal.Actions + ( moveUp + , moveDown + , moveLeft + , moveRight + , setMonthBefore + , setMonthAfter + , setYearBefore + , setYearAfter + ) where + +import Data.Time +import Data.Time.Calendar.Month + +import Brick.Widgets.Calendar.Internal.Core + +moveUp :: CalendarState -> CalendarState +moveUp = + navigateSelection (addDays (-7)) + +moveDown :: CalendarState -> CalendarState +moveDown = + navigateSelection (addDays 7) + +moveLeft :: CalendarState -> CalendarState +moveLeft = + navigateSelection (addDays (-1)) + +moveRight :: CalendarState -> CalendarState +moveRight = + navigateSelection (addDays 1) + +setMonthBefore :: CalendarState -> CalendarState +setMonthBefore = + navigateMonth (addMonths (-1)) + +setMonthAfter :: CalendarState -> CalendarState +setMonthAfter = + navigateMonth (addMonths 1) + +setYearBefore :: CalendarState -> CalendarState +setYearBefore = + navigateMonth (addMonths (-12)) + +setYearAfter :: CalendarState -> CalendarState +setYearAfter = + navigateMonth (addMonths 12) + +navigateSelection :: (Day -> Day) -> CalendarState -> CalendarState +navigateSelection dayTransform s = + case calSelectedDay s of + Nothing -> + -- When no day is selected, select the first day of the current month + s { calSelectedDay = Just $ fromGregorian (calYear s) (calMonth s) 1 } + Just day -> + let newDay = dayTransform day + (y, m, _) = toGregorian newDay + in if m /= calMonth s || y /= calYear s + -- If we've moved to a different month, update the view + then s { calYear = y, calMonth = m, calSelectedDay = Just newDay } + -- Otherwise just update the selected day + else s { calSelectedDay = Just newDay } + +navigateMonth :: (Month -> Month) -> CalendarState -> CalendarState +navigateMonth monthTransform s = + let currentYM = YearMonth (calYear s) (calMonth s) + newYM = monthTransform currentYM + YearMonth newYear newMonth = newYM + + -- Keep the same day if possible in the new month + newDay = case calSelectedDay s of + Nothing -> Nothing + Just day -> + let (_, _, d) = toGregorian day + lastDayInNewMonth = periodLength newYM + adjustedDay = min d lastDayInNewMonth + in Just $ fromGregorian newYear newMonth adjustedDay + + in s { calYear = newYear, calMonth = newMonth, calSelectedDay = newDay } diff --git a/src/Brick/Widgets/Calendar/Internal/Core.hs b/src/Brick/Widgets/Calendar/Internal/Core.hs new file mode 100644 --- /dev/null +++ b/src/Brick/Widgets/Calendar/Internal/Core.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} + +module Brick.Widgets.Calendar.Internal.Core + ( -- * Types + CalendarConfig(..) + , DayLabelStyle(..) + , OutsideMonthDisplay(..) + , DateFormat(..) + , CalendarState(..) + , defaultCalendarConfig + + -- * Lenses + , weekStart + , dayLabelStyle + , showDayLabels + , outsideMonthDisplay + , dateFormat + + -- * Resource name + , CalendarResource(..) + ) where + +import Data.Time (DayOfWeek(..), Day) +import Lens.Micro.TH ( makeLenses ) + +-- | Style for displaying day labels. +data DayLabelStyle = + SingleChar -- ^ Use single characters: S M T W T F S + | DoubleChar -- ^ Use two characters: Su Mo Tu We Th Fr Sa + | DistinctInitials -- ^ Use single chars with Th for Thursday: S M T W Th F S + deriving (Show, Eq) + +-- | How to display days outside the current month. +data OutsideMonthDisplay = + Hide -- ^ Don't show days outside current month + | ShowDimmed -- ^ Show days outside month with dimmed styling + | ShowNormal -- ^ Show days outside month with normal styling + deriving (Show, Eq) + +-- | Format options for displaying dates in the calendar. +data DateFormat = + DefaultFormat -- ^ Use default format (%b %Y for month header, digits for days) + | CustomFormat + { headerFormat :: String -- ^ Format string for month/year header (e.g., "%B %Y") + , dayFormat :: String -- ^ Format string for days (e.g., "%d") + } -- ^ Use custom format strings from Data.Time.Format (%a, %d, etc.) + deriving (Show, Eq) + +-- | Configuration for the calendar widget. +data CalendarConfig = CalendarConfig + { _weekStart :: DayOfWeek -- ^ Day of week to start the calendar + , _dayLabelStyle :: DayLabelStyle -- ^ Style for day labels + , _showDayLabels :: Bool -- ^ Whether to show day labels at all + , _outsideMonthDisplay :: OutsideMonthDisplay -- ^ How to display days outside current month + , _dateFormat :: DateFormat -- ^ Format to use for dates + } deriving (Show, Eq) + +-- | Default calendar configuration. +defaultCalendarConfig :: CalendarConfig +defaultCalendarConfig = CalendarConfig + { _weekStart = Sunday + , _dayLabelStyle = SingleChar + , _showDayLabels = True + , _outsideMonthDisplay = ShowDimmed + , _dateFormat = DefaultFormat + } + +-- | Resource name for calendar widget elements. +data CalendarResource = + CalendarDay Int Int Int -- ^ Resource for a day (year, month, day) + | CalendarMonth Int Int -- ^ Resource for month header (year, month) + | CalendarPrev -- ^ Resource for previous month button + | CalendarNext -- ^ Resource for next month button + deriving (Show, Eq, Ord) + +-- | The state of the calendar widget. Make this part of your application state. +data CalendarState = CalendarState + { calYear :: Integer -- ^ Current year + , calMonth :: Int -- ^ Current month (1-12) + , calSelectedDay :: Maybe Day -- ^ Currently selected day, if any + , calConfig :: CalendarConfig -- ^ Calendar configuration + } deriving (Show, Eq) + + + +makeLenses ''CalendarConfig diff --git a/src/Brick/Widgets/Calendar/Internal/Month.hs b/src/Brick/Widgets/Calendar/Internal/Month.hs new file mode 100644 --- /dev/null +++ b/src/Brick/Widgets/Calendar/Internal/Month.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Brick.Widgets.Calendar.Internal.Month + ( + renderCalendar + ) where + +import Brick +import Brick.Widgets.Center + +import Data.Time +import Data.Time.Calendar.Month +import Lens.Micro + +import Brick.Widgets.Calendar.Internal.Core +import Brick.Widgets.Calendar.Internal.Utils + +-- | Render a month calendar widget +renderCalendar :: CalendarState -> Widget CalendarResource +renderCalendar state@CalendarState{..} = + vBox [ renderHeader state + , if calConfig ^. showDayLabels + then renderDayLabels calConfig + else emptyWidget + , renderDays calConfig calYear calMonth calSelectedDay + ] + +-- | Render the calendar header with month/year and navigation buttons +renderHeader :: CalendarState -> Widget CalendarResource +renderHeader CalendarState{..} = + let monthText = getMonthLabel calConfig calYear calMonth + prevButton = clickable CalendarPrev $ + withAttr (attrName "calendar.nav") $ + str " << " + monthLabel = clickable (CalendarMonth (fromIntegral calYear) calMonth) $ + txt monthText + nextButton = clickable CalendarNext $ + withAttr (attrName "calendar.nav") $ + str " >> " + in hLimit 20 $ hCenter $ hBox [prevButton, monthLabel, nextButton] + +-- | Render the day labels (S M T W T F S) +renderDayLabels :: CalendarConfig -> Widget CalendarResource +renderDayLabels config = + let labels = getWeekDayLabels config + -- Create evenly spaced day labels using padRight + paddedLabels = init labels `zip` repeat (Pad 1) ++ [(last labels, Pad 0)] + makeLabel (l, p) = padRight p $ + withAttr (attrName "calendar.dayLabel") $ + txt l + in hBox $ map makeLabel paddedLabels + +-- | Render the days of the month +renderDays :: CalendarConfig -> Integer -> Int -> Maybe Day -> Widget CalendarResource +renderDays config year month selectedDay = + let yearMonth = YearMonth year month + daysInMonth = periodLength yearMonth + firstDay = getFirstDayOfMonth year month + + -- Get days of previous month that need to be displayed + prevYearMonth = addMonths (-1) yearMonth + YearMonth prevYear prevMonth = prevYearMonth + prevMonthDays = periodLength prevYearMonth + + -- Calculate start day offset more elegantly using modular arithmetic + -- This avoids nested case statements + firstDayInt = fromEnum firstDay + weekStartInt = fromEnum $ config ^. weekStart + startDayNum = (firstDayInt - weekStartInt) `mod` 7 + + -- Days from previous month to display + prevDays = + if startDayNum > 0 + then map (\d -> (prevYear, prevMonth, d, True)) + [prevMonthDays - startDayNum + 1 .. prevMonthDays] + else [] + + -- Days from current month + currentDays = map (\d -> (year, month, d, False)) [1..daysInMonth] + + -- Calculate extra days needed from next month + nextYearMonth = addMonths 1 yearMonth + YearMonth nextYear nextMonth = nextYearMonth + + -- Calculate days needed for a standard 6-row calendar (42 days total) + -- Direct calculation without intermediate variables + totalDays = length prevDays + length currentDays + daysNeeded = 42 - totalDays -- 6 rows × 7 days + + -- Create next month days to fill exactly 6 rows + nextDays = map (\d -> (nextYear, nextMonth, d, True)) [1..daysNeeded] + + -- All days to display + allDays = prevDays ++ currentDays ++ nextDays + + -- Chunked into weeks (always 6 weeks) + weeks = chunksOf 7 allDays + + -- Render a single day with appropriate padding + renderDay (dayInfo, isLast) = + let (y, m, d, isOutside) = dayInfo + day = fromGregorian y m d + isSelected = maybe False (== day) selectedDay + + -- Decide attribute based on whether day is outside current month + attr = if isOutside + then case config ^. outsideMonthDisplay of + Hide -> attrName "calendar.hidden" + ShowDimmed -> attrName "calendar.outsideMonth" + ShowNormal -> attrName "calendar.day" + else attrName "calendar.day" + + -- Add selected attribute if day is selected + finalAttr = if isSelected + then attr <> attrName "selected" + else attr + + -- Format day as text + dayText = if isOutside && config ^. outsideMonthDisplay == Hide + then " " -- Two spaces for hidden days + else formatDayNumber config day + + -- Create clickable day widget with appropriate resource identifier + baseDayWidget = clickable (CalendarDay (fromIntegral y) m d) $ + hLimit 3 $ withAttr finalAttr (txt dayText) + + -- Add padding except for the last item in each row + dayWidget = if isLast + then baseDayWidget + else padRight (Pad 1) baseDayWidget + in dayWidget + + -- Render a week by adding padding between days but not after the last one + renderWeek days = + let daysWithIsLast = zip days (replicate 6 False ++ [True]) + in hBox $ map renderDay daysWithIsLast + + in vBox $ map renderWeek weeks diff --git a/src/Brick/Widgets/Calendar/Internal/Utils.hs b/src/Brick/Widgets/Calendar/Internal/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Brick/Widgets/Calendar/Internal/Utils.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Brick.Widgets.Calendar.Internal.Utils + ( -- * Date helpers + getFirstDayOfMonth + , getDayLabel + , getMonthLabel + , getWeekDayLabels + + -- * Date formatting + , formatDate + , formatDayNumber + + -- * List helpers + , chunksOf + ) where + +import Data.Time +import Data.Time.Calendar.Month +import Data.Text (Text) +import qualified Data.Text as T +import Brick.Widgets.Calendar.Internal.Core +import Lens.Micro +import Data.List (elemIndex) +import Data.Maybe (fromMaybe) + +-- | Split a list into chunks of a given size +chunksOf :: Int -> [a] -> [[a]] +chunksOf _ [] = [] +chunksOf n xs = take n xs : chunksOf n (drop n xs) + +-- | Get the day of week for the first day of the given month +getFirstDayOfMonth :: Integer -> Int -> DayOfWeek +getFirstDayOfMonth year month = + dayOfWeek $ fromGregorian year month 1 + +-- | Get the label for a day based on the day of week and label style +getDayLabel :: DayLabelStyle -> DayOfWeek -> Text +getDayLabel style dow = case (style, dow) of + (SingleChar, Monday) -> "M " + (SingleChar, Tuesday) -> "T " + (SingleChar, Wednesday) -> "W " + (SingleChar, Thursday) -> "T " + (SingleChar, Friday) -> "F " + (SingleChar, Saturday) -> "S " + (SingleChar, Sunday) -> "S " + + (DoubleChar, Monday) -> "Mo" + (DoubleChar, Tuesday) -> "Tu" + (DoubleChar, Wednesday) -> "We" + (DoubleChar, Thursday) -> "Th" + (DoubleChar, Friday) -> "Fr" + (DoubleChar, Saturday) -> "Sa" + (DoubleChar, Sunday) -> "Su" + + (DistinctInitials, Monday) -> "M " + (DistinctInitials, Tuesday) -> "T " + (DistinctInitials, Wednesday) -> "W " + (DistinctInitials, Thursday) -> "Th" + (DistinctInitials, Friday) -> "F " + (DistinctInitials, Saturday) -> "S " + (DistinctInitials, Sunday) -> "Su" + +-- | Get the month label as text (e.g., "Apr 2025") +getMonthLabel :: CalendarConfig -> Integer -> Int -> Text +getMonthLabel config year month = + let m = YearMonth year month + day = MonthDay m 1 + fmt = case config ^. dateFormat of + DefaultFormat -> "%b %Y" + CustomFormat{headerFormat=f} -> f + in T.pack $ formatTime defaultTimeLocale fmt day + +-- | Get the labels for all days of the week based on configuration +getWeekDayLabels :: CalendarConfig -> [Text] +getWeekDayLabels config = + let startDay = config ^. weekStart + style = config ^. dayLabelStyle + allDays = [Sunday, Monday, Tuesday, Wednesday, Thursday, Friday, Saturday] + startIdx = fromMaybe 0 $ elemIndex startDay allDays + -- Rotate the list so startDay is first + weekDays = drop startIdx allDays ++ take startIdx allDays + in map (getDayLabel style) weekDays + +-- | Format a date as text using the configured format +formatDate :: CalendarConfig -> Day -> Text +formatDate config day = + let fmt = case config ^. dateFormat of + DefaultFormat -> "%Y-%m-%d" + CustomFormat{dayFormat=f} -> f + in T.pack $ formatTime defaultTimeLocale fmt day + +-- | Format a day number based on configuration (for calendar display) +formatDayNumber :: CalendarConfig -> Day -> Text +formatDayNumber config day = + let (_, _, d) = toGregorian day + fmt = case config ^. dateFormat of + DefaultFormat -> T.justifyLeft 2 ' ' (T.pack $ show d) + CustomFormat{dayFormat=f} -> T.pack $ formatTime defaultTimeLocale f day + in fmt diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,112 @@ +module Main where + +import Test.Hspec +import Brick.Widgets.Calendar +import Data.Time + +main :: IO () +main = hspec $ do + describe "Calendar Navigation" $ do + let standardState year month day = + CalendarState year month (Just $ fromGregorian year month day) defaultCalendarConfig + + describe "Directional Movement" $ do + it "correctly moves selection up" $ do + let initialState = standardState 2025 5 15 + let newState = moveUp initialState + calSelectedDay newState `shouldBe` Just (fromGregorian 2025 5 8) + + it "correctly moves selection down" $ do + let initialState = standardState 2025 5 15 + let newState = moveDown initialState + calSelectedDay newState `shouldBe` Just (fromGregorian 2025 5 22) + + it "correctly moves selection left" $ do + let initialState = standardState 2025 5 15 + let newState = moveLeft initialState + calSelectedDay newState `shouldBe` Just (fromGregorian 2025 5 14) + + it "correctly moves selection right" $ do + let initialState = standardState 2025 5 15 + let newState = moveRight initialState + calSelectedDay newState `shouldBe` Just (fromGregorian 2025 5 16) + + describe "Month Navigation" $ do + it "correctly navigates to previous month" $ do + let initialState = standardState 2025 5 15 + let newState = setMonthBefore initialState + calMonth newState `shouldBe` 4 + calYear newState `shouldBe` 2025 + + it "correctly navigates to next month" $ do + let initialState = standardState 2025 5 15 + let newState = setMonthAfter initialState + calMonth newState `shouldBe` 6 + calYear newState `shouldBe` 2025 + + describe "Year Navigation" $ do + it "correctly navigates to previous year" $ do + let initialState = standardState 2025 5 15 + let newState = setYearBefore initialState + calMonth newState `shouldBe` 5 + calYear newState `shouldBe` 2024 + + it "correctly navigates to next year" $ do + let initialState = standardState 2025 5 15 + let newState = setYearAfter initialState + calMonth newState `shouldBe` 5 + calYear newState `shouldBe` 2026 + + describe "Edge Cases" $ do + describe "Leap Year Handling" $ do + it "correctly handles date selection in leap year" $ do + let initialState = standardState 2024 2 28 + let newState = moveRight initialState + calSelectedDay newState `shouldBe` Just (fromGregorian 2024 2 29) + + it "correctly handles date selection across leap year boundary" $ do + let initialState = standardState 2024 2 29 + let newState = moveRight initialState + calSelectedDay newState `shouldBe` Just (fromGregorian 2024 3 1) + calMonth newState `shouldBe` 3 + + it "correctly navigates from leap day to next month" $ do + let initialState = standardState 2024 2 29 + let newState = setMonthAfter initialState + calSelectedDay newState `shouldBe` Just (fromGregorian 2024 3 29) + calMonth newState `shouldBe` 3 + calYear newState `shouldBe` 2024 + + it "correctly navigates from leap day to next year (non-leap year)" $ do + let initialState = standardState 2024 2 29 + let newState = setYearAfter initialState + calSelectedDay newState `shouldBe` Just (fromGregorian 2025 2 28) + calMonth newState `shouldBe` 2 + calYear newState `shouldBe` 2025 + + describe "Year Boundary Handling" $ do + it "correctly handles next month at year boundary" $ do + let initialState = standardState 2025 12 15 + let newState = setMonthAfter initialState + calMonth newState `shouldBe` 1 + calYear newState `shouldBe` 2026 + + it "correctly handles previous month at year boundary" $ do + let initialState = standardState 2025 1 15 + let newState = setMonthBefore initialState + calMonth newState `shouldBe` 12 + calYear newState `shouldBe` 2024 + + it "correctly handles next day at year boundary" $ do + let initialState = standardState 2025 12 31 + let newState = moveRight initialState + calSelectedDay newState `shouldBe` Just (fromGregorian 2026 1 1) + calMonth newState `shouldBe` 1 + calYear newState `shouldBe` 2026 + + it "correctly handles previous day at year boundary" $ do + let initialState = standardState 2025 1 1 + let newState = moveLeft initialState + calSelectedDay newState `shouldBe` Just (fromGregorian 2024 12 31) + calMonth newState `shouldBe` 12 + calYear newState `shouldBe` 2024