diff --git a/XMonad/Prompt/OrgMode.hs b/XMonad/Prompt/OrgMode.hs index c159e92b..8a38b0a5 100644 --- a/XMonad/Prompt/OrgMode.hs +++ b/XMonad/Prompt/OrgMode.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} @@ -35,6 +36,16 @@ module XMonad.Prompt.OrgMode ( -- * Types ClipboardSupport (..), OrgMode, -- abstract + +#ifdef TESTING + pInput, + Note (..), + Date (..), + Time (..), + TimeOfDay (..), + DayOfWeek (..), +#endif + ) where import XMonad.Prelude @@ -220,9 +231,11 @@ data Time = Time { date :: Date , tod :: Maybe TimeOfDay } + deriving (Eq, Show) -- | The time in HH:MM. data TimeOfDay = TimeOfDay Int Int + deriving (Eq) instance Show TimeOfDay where show :: TimeOfDay -> String @@ -241,6 +254,7 @@ data Date -- following Monday) | Date (Int, Maybe Int, Maybe Integer) -- ^ Manual date entry in the format DD [MM] [YYYY] + deriving (Eq, Ord, Show) toOrgFmt :: Maybe TimeOfDay -> Day -> String toOrgFmt tod day = @@ -282,7 +296,7 @@ dayOfWeek (ModifiedJulianDay d) = toEnum $ fromInteger $ d + 3 data DayOfWeek = Monday | Tuesday | Wednesday | Thursday | Friday | Saturday | Sunday - deriving (Show, Eq) + deriving (Eq, Ord, Show) -- | \"Circular\", so for example @[Tuesday ..]@ gives an endless -- sequence. Also: 'fromEnum' gives [1 .. 7] for [Monday .. Sunday], @@ -316,6 +330,7 @@ data Note = Scheduled String Time | Deadline String Time | NormalMsg String + deriving (Eq, Show) -- | Pretty print a given 'Note'. ppNote :: Clp -> String -> Note -> IO String diff --git a/tests/Main.hs b/tests/Main.hs index 54c8a340..b080bdb2 100644 --- a/tests/Main.hs +++ b/tests/Main.hs @@ -11,6 +11,7 @@ import qualified Selective import qualified SwapWorkspaces import qualified XPrompt import qualified CycleRecentWS +import qualified OrgMode main :: IO () main = hspec $ do @@ -47,3 +48,4 @@ main = hspec $ do context "NoBorders" NoBorders.spec context "ExtensibleConf" ExtensibleConf.spec context "CycleRecentWS" CycleRecentWS.spec + context "OrgMode" OrgMode.spec diff --git a/tests/OrgMode.hs b/tests/OrgMode.hs new file mode 100644 index 00000000..0b8d3a40 --- /dev/null +++ b/tests/OrgMode.hs @@ -0,0 +1,157 @@ +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-incomplete-patterns #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE LambdaCase #-} +module OrgMode where + +import XMonad.Prelude hiding ((!?)) +import XMonad.Prompt.OrgMode + +import qualified Data.Map.Strict as Map + +import Data.Map.Strict (Map, (!), (!?)) +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck + + +spec :: Spec +spec = do + prop "prop_encodeLinearity" prop_encodeLinearity + prop "prop_decodeLinearity" prop_decodeLinearity + +-- | Printing omits no information from output. +prop_encodeLinearity :: OrgMsg -> Bool +prop_encodeLinearity (OrgMsg s) = Just s == (ppNote <$> pInput s) + +-- | Parsing discards no information from input. +prop_decodeLinearity :: Note -> Bool +prop_decodeLinearity n = Just n == pInput (ppNote n) + +------------------------------------------------------------------------ +-- Pretty Printing + +ppNote :: Note -> String +ppNote = \case + Scheduled str t -> str <> " +s " <> ppTime t + Deadline str t -> str <> " +d " <> ppTime t + NormalMsg str -> str + +ppTime :: Time -> String +ppTime (Time d t) = ppDate d <> ppTOD t + where + ppTOD :: Maybe TimeOfDay -> String + ppTOD = maybe "" ((' ' :) . show) + + ppDate :: Date -> String + ppDate dte = case days !? dte of + Just v -> v + Nothing -> case d of -- only way it can't be in the map + Date (d', mbM, mbY) -> show d' + <> maybe "" ((' ' :) . (months !)) mbM + <> maybe "" ((' ' :) . show) mbY + +------------------------------------------------------------------------ +-- Arbitrary Instances + +-- | An arbitrary (correct) message string. +newtype OrgMsg = OrgMsg String + deriving (Show) + +instance Arbitrary OrgMsg where + arbitrary :: Gen OrgMsg + arbitrary = OrgMsg <$> + randomString <<>> elements [" +s ", " +d ", ""] <<>> dateGen <<>> hourGen + where + dateGen :: Gen String + dateGen = oneof + [ pure $ days ! Today + , pure $ days ! Tomorrow + , elements $ (days !) . Next <$> [Monday .. Sunday] + , rNat + , unwords <$> sequenceA [rNat, monthGen] + , unwords <$> sequenceA [rNat, monthGen, show <$> posInt `suchThat` (> 25)] + ] + where + rNat :: Gen String + rNat = show <$> posInt + + monthGen :: Gen String + monthGen = elements $ Map.elems months + + hourGen :: Gen String + hourGen = oneof + [ pure " " <<>> (pad <$> hourInt) <<>> pure ":" <<>> (pad <$> minuteInt) + , pure "" + ] + where + pad :: Int -> String + pad n = (if n <= 9 then "0" else "") <> show n + +instance Arbitrary Note where + arbitrary :: Gen Note + arbitrary = do + msg <- randomString + t <- arbitrary + elements [Scheduled msg t, Deadline msg t, NormalMsg msg] + +instance Arbitrary Time where + arbitrary :: Gen Time + arbitrary = Time <$> arbitrary <*> arbitrary + +instance Arbitrary Date where + arbitrary :: Gen Date + arbitrary = oneof + [ pure Today + , pure Tomorrow + , Next . toEnum <$> choose (0, 6) + , do d <- posInt + m <- mbPos `suchThat` (<= Just 12) + Date . (d, m, ) <$> if isNothing m + then pure Nothing + else mbPos `suchThat` (>= Just 25) + ] + +instance Arbitrary TimeOfDay where + arbitrary :: Gen TimeOfDay + arbitrary = TimeOfDay <$> hourInt <*> minuteInt + +------------------------------------------------------------------------ +-- Util + +randomString :: Gen String +randomString = listOf arbitraryPrintableChar <<>> (noSpace <&> (: [])) + where + noSpace :: Gen Char + noSpace = arbitraryPrintableChar `suchThat` (/= ' ') + +days :: Map Date String +days = Map.fromList + [ (Today, "tod"), (Tomorrow, "tom"), (Next Monday, "m"), (Next Tuesday, "tu") + , (Next Wednesday, "w"), (Next Thursday, "th"), (Next Friday, "f") + , (Next Saturday,"sa"), (Next Sunday,"su") + ] + +months :: Map Int String +months = Map.fromList + [ (1, "ja"), (2, "f"), (3, "mar"), (4, "ap"), (5, "may"), (6, "jun") + , (7, "jul"), (8, "au"), (9, "s"), (10, "o"), (11, "n"), (12, "d") + ] + +posInt :: Gen Int +posInt = getPositive <$> arbitrary @(Positive Int) + +hourInt :: Gen Int +hourInt = posInt `suchThat` (<= 23) + +minuteInt :: Gen Int +minuteInt = posInt `suchThat` (<= 59) + +mbPos :: Num a => Gen (Maybe a) +mbPos = fmap (fromIntegral . getPositive) <$> arbitrary @(Maybe (Positive Int)) + +infixr 6 <<>> +(<<>>) :: (Applicative f, Monoid a) => f a -> f a -> f a +(<<>>) = liftA2 (<>) diff --git a/xmonad-contrib.cabal b/xmonad-contrib.cabal index 7af73601..adffdfe7 100644 --- a/xmonad-contrib.cabal +++ b/xmonad-contrib.cabal @@ -378,6 +378,7 @@ test-suite tests Instances ManageDocks NoBorders + OrgMode RotateSome Selective SwapWorkspaces @@ -397,6 +398,7 @@ test-suite tests XMonad.Layout.NoBorders XMonad.Prelude XMonad.Prompt + XMonad.Prompt.OrgMode XMonad.Prompt.Shell XMonad.Util.ExtensibleConf XMonad.Util.ExtensibleState @@ -418,6 +420,7 @@ test-suite tests , X11 >= 1.10 && < 1.11 , containers , directory + , time >= 1.8 && < 1.12 , hspec >= 2.4.0 && < 3 , mtl , process