{-# LANGUAGE ViewPatterns    #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE CPP             #-}
--------------------------------------------------------------------
-- |
-- Module      : System.Cron.Describe
-- Description : Turn a cron schedule into a human-readable string
-- Copyright   : (c) Joseph Canero 2016
-- License     : MIT
--
-- Maintainer: Joseph Canero <jmc41493@gmail.com>
-- Portability: portable
--
--
-- > import System.Cron
-- >
-- > main :: IO ()
-- > main = do
-- >   let Right cs1 = parseCronSchedule "*/2 * 3 * 4,5,6"
-- >   print $ describe defaultOpts cs1
-- >
-- >   let Right cs2 = parseCronSchedule "*/2 12 3 * 4,5,6"
-- >   print $ describe (twentyFourHourFormat <> verbose) cs2
--------------------------------------------------------------------
module System.Cron.Describe
    (
      -- * Options handling
      defaultOpts
    , twentyFourHourFormat
    , twelveHourFormat
    , verbose
    , notVerbose
    , OptionBuilder
      -- * Describe a CronSchedule
    , describe
    ) where

-------------------------------------------------------------------------------
import Control.Monad
import Data.List.NonEmpty                       (NonEmpty (..), toList)
import Data.Maybe                               (fromJust)
#if !MIN_VERSION_base(4,8,0)
import Data.Traversable                         (traverse)
#endif
-------------------------------------------------------------------------------
import System.Cron.Internal.Describe.Descriptors
import System.Cron.Internal.Describe.Options
import System.Cron.Internal.Describe.Time
import System.Cron.Internal.Describe.Types
import System.Cron.Internal.Describe.Utils
import System.Cron.Types
-------------------------------------------------------------------------------


-- | Given an 'OptionBuilder' and a 'CronSchedule' parsed with
-- 'System.Cron.Parser.parseCronSchedule', return a human-readable string
-- describing when that schedule will match.
describe :: OptionBuilder -> CronSchedule -> String
describe :: OptionBuilder -> CronSchedule -> String
describe OptionBuilder
ob = String -> String
cap                      (String -> String)
-> (CronSchedule -> String) -> CronSchedule -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
              Description -> String
forall a. Show a => a -> String
show                     (Description -> String)
-> (CronSchedule -> Description) -> CronSchedule -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
              Verbosity -> Description -> Description
matchVerbosity Verbosity
verbosity (Description -> Description)
-> (CronSchedule -> Description) -> CronSchedule -> Description
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
              TimeFormat -> CronSchedule -> Description
description TimeFormat
timeFormat
  where Opts{TimeFormat
Verbosity
verbosity :: Verbosity
timeFormat :: TimeFormat
timeFormat :: Options -> TimeFormat
verbosity :: Options -> Verbosity
..} = OptionBuilder -> Options
getOpts OptionBuilder
ob


-------------------------------------------------------------------------------
-- Internals
-------------------------------------------------------------------------------


describeRange :: RangeField -> Descriptor -> String
describeRange :: RangeField -> Descriptor -> String
describeRange RangeField
rf Descriptor
d = [String] -> String
allWords [Descriptor -> String
rangePrefix Descriptor
d,
                               Descriptor -> Int -> String
displayItem Descriptor
d (RangeField -> Int
rfBegin RangeField
rf),
                               Descriptor -> String
rangeJoiner Descriptor
d,
                               Descriptor -> Int -> String
displayItem Descriptor
d (RangeField -> Int
rfEnd RangeField
rf),
                               Descriptor -> String
rangeSuffix Descriptor
d]


describeBaseField :: Descriptor -> BaseField -> DescribedValue
describeBaseField :: Descriptor -> BaseField -> DescribedValue
describeBaseField Descriptor
d (RangeField' RangeField
rf)   = String -> DescribedValue
Concrete (String -> DescribedValue) -> String -> DescribedValue
forall a b. (a -> b) -> a -> b
$ RangeField -> Descriptor -> String
describeRange RangeField
rf Descriptor
d
describeBaseField Descriptor
d BaseField
Star               = String -> DescribedValue
Every (String -> DescribedValue) -> String -> DescribedValue
forall a b. (a -> b) -> a -> b
$ String
"every " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Descriptor -> String
singularDesc Descriptor
d
describeBaseField Descriptor
d (SpecificField' SpecificField
s) =
  String -> DescribedValue
Concrete (String -> DescribedValue) -> String -> DescribedValue
forall a b. (a -> b) -> a -> b
$ [String] -> String
allWords [Descriptor -> String
specificPrefix Descriptor
d,
                       Descriptor -> Int -> String
displayItem Descriptor
d (SpecificField -> Int
specificField SpecificField
s),
                       Descriptor -> String
specificSuffix Descriptor
d]


type StarOrDesc = Either String String


describeListFields :: (BaseField -> String) -> NonEmpty BaseField -> StarOrDesc
describeListFields :: (BaseField -> String) -> NonEmpty BaseField -> StarOrDesc
describeListFields BaseField -> String
f (BaseField
l :| [BaseField]
ls) =
  ([String] -> String) -> Either String [String] -> StarOrDesc
forall a b. (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [String] -> String
joinWords (Either String [String] -> StarOrDesc)
-> ([BaseField] -> Either String [String])
-> [BaseField]
-> StarOrDesc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([String] -> BaseField -> Either String [String])
-> [String] -> [BaseField] -> Either String [String]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM [String] -> BaseField -> Either String [String]
describeF [] ([BaseField] -> StarOrDesc) -> [BaseField] -> StarOrDesc
forall a b. (a -> b) -> a -> b
$ [BaseField] -> [BaseField]
forall a. [a] -> [a]
reverse (BaseField
lBaseField -> [BaseField] -> [BaseField]
forall a. a -> [a] -> [a]
:[BaseField]
ls)
  where describeF :: [String] -> BaseField -> Either String [String]
describeF [String]
_ BaseField
Star = String -> Either String [String]
forall a b. a -> Either a b
Left (String -> Either String [String])
-> String -> Either String [String]
forall a b. (a -> b) -> a -> b
$ BaseField -> String
f BaseField
Star
        describeF [String]
e BaseField
bf   = [String] -> Either String [String]
forall a b. b -> Either a b
Right ([String] -> Either String [String])
-> [String] -> Either String [String]
forall a b. (a -> b) -> a -> b
$ BaseField -> String
f BaseField
bf String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
e



describeCronField :: Descriptor -> CronField -> DescribedValue
describeCronField :: Descriptor -> CronField -> DescribedValue
describeCronField Descriptor
d (Field BaseField
f) = Descriptor -> BaseField -> DescribedValue
describeBaseField Descriptor
d BaseField
f


describeCronField Descriptor
d (StepField' StepField
sf) = String -> DescribedValue
Concrete (String -> DescribedValue) -> String -> DescribedValue
forall a b. (a -> b) -> a -> b
$
  String
stepPrefix String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> (String -> String) -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (String
", " String -> String -> String
forall a. [a] -> [a] -> [a]
++) (BaseField -> Maybe String
stepSuffix (BaseField -> Maybe String) -> BaseField -> Maybe String
forall a b. (a -> b) -> a -> b
$ StepField -> BaseField
sfField StepField
sf)
  where
    stepPrefix :: String
stepPrefix = [String] -> String
unwords [String
"every", Int -> String
forall a. Show a => a -> String
show (StepField -> Int
sfStepping StepField
sf), Descriptor -> String
pluralDesc Descriptor
d]
    stepSuffix :: BaseField -> Maybe String
stepSuffix BaseField
Star              = Maybe String
forall a. Maybe a
Nothing
    stepSuffix (RangeField' RangeField
rf)  = String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ RangeField -> Descriptor -> String
describeRange RangeField
rf Descriptor
d
    stepSuffix (SpecificField' SpecificField
s) = Descriptor -> Int -> Maybe String
stepSpecificSuffix Descriptor
d (Int -> Maybe String) -> Int -> Maybe String
forall a b. (a -> b) -> a -> b
$ SpecificField -> Int
specificField SpecificField
s


describeCronField Descriptor
d (ListField NonEmpty BaseField
ls) =
  case (BaseField -> String) -> NonEmpty BaseField -> StarOrDesc
describeListFields BaseField -> String
describeBF NonEmpty BaseField
ls of
    Left  String
s -> String -> DescribedValue
Every String
s
    Right String
s -> String -> DescribedValue
Concrete (String -> DescribedValue) -> String -> DescribedValue
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [Descriptor -> String
listPrefix Descriptor
d,
                                   String -> (String -> String) -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
s ((String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" ") String -> String -> String
forall a. [a] -> [a] -> [a]
++) (Descriptor -> Maybe String
listSuffix Descriptor
d)]
  where
    describeBF :: BaseField -> String
describeBF BaseField
Star               = String
"every " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Descriptor -> String
singularDesc Descriptor
d
    describeBF (SpecificField' SpecificField
s) = Descriptor -> Int -> String
displayItem Descriptor
d (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ SpecificField -> Int
specificField SpecificField
s
    describeBF (RangeField' RangeField
rf)   = [String] -> String
unwords [Descriptor -> Int -> String
displayItem Descriptor
d (RangeField -> Int
rfBegin RangeField
rf),
                                             String
"through",
                                             Descriptor -> Int -> String
displayItem Descriptor
d (RangeField -> Int
rfEnd RangeField
rf)]

-- There are a few special cases to handle when describing the minute and hour
-- fields that will make the cron description easier to read.
-- For the most part, these are pretty straight forward. The first three
-- pattern matches look for specific patterns in the minute and hour fields that
-- can be formatted differently. The last pattern match just defaults
-- to describing the fields using existing rules.
describeTime :: TimeFormat -> MinuteSpec -> HourSpec -> Time
describeTime :: TimeFormat -> MinuteSpec -> HourSpec -> Time
describeTime TimeFormat
tf (MinuteSpec -> Maybe Minute
viewMinute -> Just Minute
m) (HourSpec -> Maybe Hour
viewHour -> Just Hour
h) =
  String -> Time
ConcreteTime (String -> Time) -> String -> Time
forall a b. (a -> b) -> a -> b
$ String
"at " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TimeFormat -> Minute -> Hour -> String
format TimeFormat
tf Minute
m Hour
h
describeTime TimeFormat
tf (MinuteSpec -> Maybe (Minute, Minute)
viewMinuteRange -> Just (Minute
m1, Minute
m2)) (HourSpec -> Maybe Hour
viewHour -> Just Hour
h) =
  String -> Time
ConcreteTime (String -> Time) -> String -> Time
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [String
"every minute between",
                          TimeFormat -> Minute -> Hour -> String
format TimeFormat
tf Minute
m1 Hour
h,
                          String
"and",
                          TimeFormat -> Minute -> Hour -> String
format TimeFormat
tf Minute
m2 Hour
h]
describeTime TimeFormat
tf (MinuteSpec -> Maybe Minute
viewMinute -> Just Minute
m) (HourSpec -> Maybe (NonEmpty BaseField)
viewHourList -> Just NonEmpty BaseField
hs) =
  TimeFormat -> Minute -> NonEmpty BaseField -> Time
describeMultHours TimeFormat
tf Minute
m NonEmpty BaseField
hs
describeTime TimeFormat
tf (MinuteSpec -> CronField
minuteSpec -> CronField
m) (HourSpec -> CronField
hourSpec -> CronField
h) =
  Maybe DescribedValue -> Maybe DescribedValue -> Time
Other (DescribedValue -> Maybe DescribedValue
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (DescribedValue -> Maybe DescribedValue)
-> DescribedValue -> Maybe DescribedValue
forall a b. (a -> b) -> a -> b
$ Descriptor -> CronField -> DescribedValue
describeCronField Descriptor
minuteDescriptor CronField
m)
        (DescribedValue -> Maybe DescribedValue
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (DescribedValue -> Maybe DescribedValue)
-> DescribedValue -> Maybe DescribedValue
forall a b. (a -> b) -> a -> b
$ Descriptor -> CronField -> DescribedValue
describeCronField (TimeFormat -> Descriptor
hourDescriptor TimeFormat
tf) CronField
h)

-- We want to create a description for multiple hours given a concrete minute.
-- This is rather ugly, as the ListField type allows for any BaseField, so
-- we can potentially have a '*' within the list. In that case, we don't need
-- to describe the rest of the BaseFields for hour list, since we will just be
-- firing each hour.
describeMultHours :: TimeFormat -> Minute -> NonEmpty BaseField -> Time
describeMultHours :: TimeFormat -> Minute -> NonEmpty BaseField -> Time
describeMultHours TimeFormat
t mn :: Minute
mn@(Minute Int
m) NonEmpty BaseField
ls =
  Time
-> (NonEmpty String -> Time) -> Maybe (NonEmpty String) -> Time
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Time
mkOther ([String] -> Time
formatAllFields ([String] -> Time)
-> (NonEmpty String -> [String]) -> NonEmpty String -> Time
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty String -> [String]
forall a. NonEmpty a -> [a]
toList) (Maybe (NonEmpty String) -> Time)
-> Maybe (NonEmpty String) -> Time
forall a b. (a -> b) -> a -> b
$ (BaseField -> Maybe String)
-> NonEmpty BaseField -> Maybe (NonEmpty String)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> NonEmpty a -> f (NonEmpty b)
traverse BaseField -> Maybe String
formatBaseField NonEmpty BaseField
ls
  where hourCF :: CronField
hourCF   = NonEmpty BaseField -> CronField
ListField NonEmpty BaseField
ls
        minuteCF :: CronField
minuteCF = BaseField -> CronField
Field (SpecificField -> BaseField
SpecificField' (Maybe SpecificField -> SpecificField
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe SpecificField -> SpecificField)
-> Maybe SpecificField -> SpecificField
forall a b. (a -> b) -> a -> b
$ Int -> Maybe SpecificField
mkSpecificField Int
m))

        formatAllFields :: [String] -> Time
formatAllFields = String -> Time
ConcreteTime (String -> Time) -> ([String] -> String) -> [String] -> Time
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"at " String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String) -> ([String] -> String) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
joinWords

        formatBaseField :: BaseField -> Maybe String
formatBaseField (SpecificField' SpecificField
s) =
          String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ TimeFormat -> Minute -> Hour -> String
format TimeFormat
t Minute
mn (Int -> Hour
Hour (SpecificField -> Int
specificField SpecificField
s))
        formatBaseField BaseField
Star               = Maybe String
forall a. Maybe a
Nothing
        formatBaseField f :: BaseField
f@(RangeField' RangeField
_)  =
          String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [DescribedValue -> String
forall a. Show a => a -> String
show DescribedValue
describedMinute,
                          DescribedValue -> String
forall a. Show a => a -> String
show (DescribedValue -> String) -> DescribedValue -> String
forall a b. (a -> b) -> a -> b
$ Descriptor -> CronField -> DescribedValue
describeCronField (TimeFormat -> Descriptor
hourDescriptor TimeFormat
t) (BaseField -> CronField
Field BaseField
f)]

        mkOther :: Time
mkOther = Maybe DescribedValue -> Maybe DescribedValue -> Time
Other (DescribedValue -> Maybe DescribedValue
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return DescribedValue
describedMinute)
                        (DescribedValue -> Maybe DescribedValue
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (DescribedValue -> Maybe DescribedValue)
-> DescribedValue -> Maybe DescribedValue
forall a b. (a -> b) -> a -> b
$ Descriptor -> CronField -> DescribedValue
describeCronField (TimeFormat -> Descriptor
hourDescriptor TimeFormat
t) CronField
hourCF)
        describedMinute :: DescribedValue
describedMinute = Descriptor -> CronField -> DescribedValue
describeCronField Descriptor
minuteDescriptor CronField
minuteCF


description :: TimeFormat -> CronSchedule -> Description
description :: TimeFormat -> CronSchedule -> Description
description TimeFormat
t CronSchedule
c = Time
-> Maybe DescribedValue
-> Maybe DescribedValue
-> Maybe DescribedValue
-> Description
Desc (TimeFormat -> MinuteSpec -> HourSpec -> Time
describeTime TimeFormat
t (CronSchedule -> MinuteSpec
minute CronSchedule
c) (CronSchedule -> HourSpec
hour CronSchedule
c))
                       (DescribedValue -> Maybe DescribedValue
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return DescribedValue
ddom)
                       (DescribedValue -> Maybe DescribedValue
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return DescribedValue
dm)
                       (DescribedValue -> Maybe DescribedValue
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return DescribedValue
ddow)
  where ddom :: DescribedValue
ddom = Descriptor -> CronField -> DescribedValue
describeCronField Descriptor
domDescriptor (CronField -> DescribedValue) -> CronField -> DescribedValue
forall a b. (a -> b) -> a -> b
$ DayOfMonthSpec -> CronField
dayOfMonthSpec (CronSchedule -> DayOfMonthSpec
dayOfMonth CronSchedule
c)
        dm :: DescribedValue
dm   = Descriptor -> CronField -> DescribedValue
describeCronField Descriptor
monthDescriptor (CronField -> DescribedValue) -> CronField -> DescribedValue
forall a b. (a -> b) -> a -> b
$ MonthSpec -> CronField
monthSpec (CronSchedule -> MonthSpec
month CronSchedule
c)
        ddow :: DescribedValue
ddow = Descriptor -> CronField -> DescribedValue
describeCronField Descriptor
dowDescriptor (CronField -> DescribedValue) -> CronField -> DescribedValue
forall a b. (a -> b) -> a -> b
$ DayOfWeekSpec -> CronField
dayOfWeekSpec (CronSchedule -> DayOfWeekSpec
dayOfWeek CronSchedule
c)


matchVerbosity :: Verbosity -> Description -> Description
matchVerbosity :: Verbosity -> Description -> Description
matchVerbosity Verbosity
v d :: Description
d@Desc{Maybe DescribedValue
Time
_time :: Time
_dom :: Maybe DescribedValue
_month :: Maybe DescribedValue
_dow :: Maybe DescribedValue
_time :: Description -> Time
_dom :: Description -> Maybe DescribedValue
_month :: Description -> Maybe DescribedValue
_dow :: Description -> Maybe DescribedValue
..} = Description
d{  _dom   = stripEvery v =<< _dom
                                , _dow   = stripEvery v =<< _dow
                                , _time  = stripTime _time
                                , _month = stripEvery NotVerbose =<< _month}
  where stripTime :: Time -> Time
stripTime t :: Time
t@(ConcreteTime String
_)   = Time
t
        stripTime (Other Maybe DescribedValue
mbMin Maybe DescribedValue
mbHour) = Maybe DescribedValue -> Maybe DescribedValue -> Time
Other Maybe DescribedValue
mbMin (Verbosity -> DescribedValue -> Maybe DescribedValue
stripEvery Verbosity
v (DescribedValue -> Maybe DescribedValue)
-> Maybe DescribedValue -> Maybe DescribedValue
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe DescribedValue
mbHour)


stripEvery :: Verbosity -> DescribedValue -> Maybe DescribedValue
stripEvery :: Verbosity -> DescribedValue -> Maybe DescribedValue
stripEvery Verbosity
NotVerbose (Every String
_) = Maybe DescribedValue
forall a. Maybe a
Nothing
stripEvery Verbosity
_          DescribedValue
c         = DescribedValue -> Maybe DescribedValue
forall a. a -> Maybe a
Just DescribedValue
c