diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -71,3 +71,4 @@ * [Andrew Rademacher](https://github.com/AndrewRademacher) * [Peter Simons](https://github.com/peti) * [Joseph Canero](https://github.com/caneroj1) +* [Ahti Katiska](https://github.com/HariGyogu) diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,3 +1,5 @@ +# 0.6.1 +* Add support for day and month literals, Ahti Katiska (@HariGyogu). # 0.6.0 * Use Text instead of String in Cron.Schedule # 0.5.0 diff --git a/cron.cabal b/cron.cabal --- a/cron.cabal +++ b/cron.cabal @@ -1,5 +1,5 @@ Name: cron -Version: 0.6.0 +Version: 0.6.1 Description: Cron data structure and Attoparsec parser. The idea is to embed it in larger systems which want to roll their own scheduled tasks in a format that people diff --git a/src/System/Cron/Parser.hs b/src/System/Cron/Parser.hs --- a/src/System/Cron/Parser.hs +++ b/src/System/Cron/Parser.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------- -- | @@ -32,12 +33,13 @@ ) where ------------------------------------------------------------------------------- -import Control.Applicative as Ap -import Data.Attoparsec.Text (Parser) -import qualified Data.Attoparsec.Text as A -import Data.Char (isSpace) -import Data.List.NonEmpty (NonEmpty (..)) -import Data.Text (Text) +import Control.Applicative as Ap +import Data.Attoparsec.Combinator (choice) +import Data.Attoparsec.Text (Parser) +import qualified Data.Attoparsec.Text as A +import Data.Char (isSpace) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Text (Text, toLower) ------------------------------------------------------------------------------- import System.Cron.Types ------------------------------------------------------------------------------- @@ -97,7 +99,7 @@ parseCronSchedule :: Text -> Either String CronSchedule -parseCronSchedule = A.parseOnly cronSchedule +parseCronSchedule = A.parseOnly cronSchedule . toLower ------------------------------------------------------------------------------- @@ -135,21 +137,21 @@ ------------------------------------------------------------------------------- -cronFieldP :: Parser CronField -cronFieldP = stepP <|> - listP <|> - fieldP - +cronFieldP :: StringSupport -> Parser CronField +cronFieldP stringSupport = + stepP <|> + listP <|> + fieldP where - fieldP = Field <$> baseFieldP - listP = ListField <$> neListP baseFieldP - stepP = StepField' <$> stepFieldP + fieldP = Field <$> baseFieldP stringSupport + listP = ListField <$> neListP (baseFieldP stringSupport) + stepP = StepField' <$> stepFieldP stringSupport ------------------------------------------------------------------------------- -stepFieldP :: Parser StepField -stepFieldP = do - f <- baseFieldP +stepFieldP :: StringSupport -> Parser StepField +stepFieldP ss = do + f <- baseFieldP ss _ <- A.char '/' mParse (mkStepField f) "invalid stepping" =<< parseInt @@ -164,29 +166,27 @@ ------------------------------------------------------------------------------- -baseFieldP :: Parser BaseField -baseFieldP = rangeP <|> - starP <|> - specificP +baseFieldP :: StringSupport -> Parser BaseField +baseFieldP ss = rangeP <|> + starP <|> + specificP where starP = A.char '*' *> Ap.pure Star - rangeP = RangeField' <$> rangeFieldP - specificP = SpecificField' <$> specificFieldP + rangeP = RangeField' <$> rangeFieldP ss + specificP = SpecificField' <$> specificFieldP ss ------------------------------------------------------------------------------- -specificFieldP :: Parser SpecificField -specificFieldP = - mParse mkSpecificField "specific field value out of range" =<< parseInt - +specificFieldP :: StringSupport -> Parser SpecificField +specificFieldP ss = + mParse mkSpecificField "specific field value out of range" + =<< supportParser ss ------------------------------------------------------------------------------- -rangeFieldP :: Parser RangeField -rangeFieldP = do - begin <- parseInt - - +rangeFieldP :: StringSupport -> Parser RangeField +rangeFieldP ss = do + begin <- supportParser ss _ <- A.char '-' - end <- parseInt + end <- supportParser ss mParse (mkRangeField begin) "start of range must be less than or equal to end" end @@ -217,33 +217,85 @@ ------------------------------------------------------------------------------- minutesP :: Parser MinuteSpec -minutesP = mParse mkMinuteSpec "minutes out of range" =<< cronFieldP +minutesP = mParse mkMinuteSpec "minutes out of range" =<< cronFieldP NoString ------------------------------------------------------------------------------- hoursP :: Parser HourSpec -hoursP = mParse mkHourSpec "hours out of range" =<< cronFieldP +hoursP = mParse mkHourSpec "hours out of range" =<< cronFieldP NoString ------------------------------------------------------------------------------- dayOfMonthP :: Parser DayOfMonthSpec -dayOfMonthP = mParse mkDayOfMonthSpec "day of month out of range" =<< cronFieldP +dayOfMonthP = mParse mkDayOfMonthSpec "day of month out of range" =<< cronFieldP NoString ------------------------------------------------------------------------------- monthP :: Parser MonthSpec -monthP = mParse mkMonthSpec "month out of range" =<< cronFieldP +monthP = mParse mkMonthSpec "month out of range" =<< cronFieldP MonthString ------------------------------------------------------------------------------- dayOfWeekP :: Parser DayOfWeekSpec -dayOfWeekP = mParse mkDayOfWeekSpec "day of week out of range" =<< cronFieldP +dayOfWeekP = mParse mkDayOfWeekSpec "day of week out of range" =<< cronFieldP DayString ------------------------------------------------------------------------------- parseInt :: Parser Int parseInt = A.decimal +------------------------------------------------------------------------------- +data StringSupport + = MonthString + | DayString + | NoString + deriving Eq + +------------------------------------------------------------------------------- +supportParser :: StringSupport -> Parser Int +supportParser = \case + MonthString -> choice [parseMonth, parseInt] + DayString -> choice [parseDay, parseInt] + NoString -> parseInt + +------------------------------------------------------------------------------- + +toI :: Int -> Text -> Parser Int +toI int str = const int <$> A.string str + +------------------------------------------------------------------------------- +parseDay :: Parser Int +parseDay = + choice $ + zipWith toI + [1 .. 7] + [ "mon" + , "tue" + , "wed" + , "thu" + , "fri" + , "sat" + , "sun" + ] + +------------------------------------------------------------------------------- +parseMonth :: Parser Int +parseMonth = + choice $ + zipWith toI + [1 .. 12] + [ "jan" + , "feb" + , "mar" + , "apr" + , "may" + , "jun" + , "jul" + , "aug" + , "sep" + , "oct" + , "nov" + , "dec"] ------------------------------------------------------------------------------- mParse :: (Monad m) => (a -> Maybe b) -> String -> a -> m b diff --git a/test/SpecHelper.hs b/test/SpecHelper.hs --- a/test/SpecHelper.hs +++ b/test/SpecHelper.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -22,6 +23,7 @@ import Data.Time.LocalTime as X import Debug.Trace as X import qualified Generics.SOP as SOP +import qualified Generics.SOP.Constraint as SOP import qualified Generics.SOP.GGP as SOP import GHC.Generics (Generic) import Test.QuickCheck.Instances () @@ -36,11 +38,11 @@ -- this workaround is in place until we successfully beat down the -- doors of castle QuickCheck and get generic deriving through. See -- -sopArbitrary :: (Generic a, SOP.GTo a, SOP.All SOP.SListI (SOP.GCode a), SOP.All2 Arbitrary (SOP.GCode a)) => Gen a +sopArbitrary :: (SOP.GTo b, SOP.SListI (SOP.GCode b), Generic b, SOP.AllF (SOP.All Arbitrary) (SOP.GCode b), SOP.AllF SOP.SListI (SOP.GCode b)) => Gen b sopArbitrary = fmap SOP.gto sopArbitrary' -sopArbitrary' :: (SOP.All SOP.SListI xss, SOP.All2 Arbitrary xss) => Gen (SOP.SOP SOP.I xss) +sopArbitrary' :: (SOP.SListI xss, SOP.AllF SOP.SListI xss, SOP.AllF (SOP.All Arbitrary) xss) => Gen (SOP.SOP SOP.I xss) sopArbitrary' = oneof (map SOP.hsequence $ SOP.apInjs_POP $ SOP.hcpure p arbitrary) where p :: Proxy Arbitrary