Initial commit

6 files changed, 454 insertions, 0 deletions

diff --git a/src/Common.hs b/src/Common.hs
new file mode 100644
index 0000000..a196527
--- /dev/null
+++ b/src/Common.hs
@@ -0,0 +1,71 @@
+module Common ((?), (?:), fromDigits, leftPad, listToProse, asOrdinal, showDayOfWeek, showMonth) where
+
+import Data.List (replicate, take)
+import Data.List.NonEmpty (NonEmpty ((:|)))
+import Data.Maybe (fromMaybe)
+import Intro
+
+fromDigits :: [Int] -> Int
+fromDigits = foldl (\n d -> 10 * n + d) 0
+
+leftPad :: Int -> a -> [a] -> [a]
+leftPad m x xs = replicate (m - length ys) x ++ ys
+ where
+  ys = take m xs
+
+(?) :: Bool -> a -> a -> a
+(?) True x _ = x
+(?) False _ y = y
+
+infixr 1 ?
+
+(?:) :: Maybe a -> a -> a
+maybeA ?: b = fromMaybe b maybeA
+
+infixr 0 ?:
+
+listToProse :: NonEmpty String -> String
+listToProse (x :| xs) = mconcat . reverse $ proseJoin xs [x]
+ where
+  proseJoin [] ys = ys
+  proseJoin [y] [] = [y]
+  proseJoin [y] zs = y : " and " : zs
+  proseJoin (y : ys) zs = proseJoin ys (y : ", " : zs)
+
+asOrdinal :: Int -> String
+asOrdinal 11 = "11th"
+asOrdinal 12 = "12th"
+asOrdinal 13 = "13th"
+asOrdinal n =
+  show n ++ case n `mod` 10 of
+    1 -> "st"
+    2 -> "nd"
+    3 -> "rd"
+    _ -> "th"
+
+showDayOfWeek :: Int -> Maybe String
+showDayOfWeek = \case
+  0 -> Just "Sunday"
+  1 -> Just "Monday"
+  2 -> Just "Tuesday"
+  3 -> Just "Wednesday"
+  4 -> Just "Thursday"
+  5 -> Just "Friday"
+  6 -> Just "Saturday"
+  _ -> Nothing
+
+showMonth :: Int -> Maybe String
+showMonth = \case
+  1 -> Just "January"
+  2 -> Just "February"
+  3 -> Just "March"
+  4 -> Just "April"
+  5 -> Just "May"
+  6 -> Just "June"
+  7 -> Just "July"
+  8 -> Just "August"
+  9 -> Just "September"
+  10 -> Just "October"
+  11 -> Just "November"
+  12 -> Just "December"
+  _ -> Nothing
diff --git a/src/Cron.hs b/src/Cron.hs
new file mode 100644
index 0000000..3cadac9
--- /dev/null
+++ b/src/Cron.hs
@@ -0,0 +1,138 @@
+module Cron (parse, toProse) where
+
+import Common (asOrdinal, leftPad, listToProse, showDayOfWeek, showMonth, (?:))
+import qualified Cron.Expr as E
+import qualified Cron.Schedule as S
+import Data.List.NonEmpty (NonEmpty ((:|)))
+import Intro
+
+parse :: String -> Either String S.Schedule
+parse s = case words s of
+  [mn, h, dom, m, dow] -> S.fromParts mn h dom m dow
+  xs ->
+    Left
+      $ "Invalid cron "
+      ++ s
+      ++ ": not enough qualifiers, expecting 5 but only got "
+      ++ (show . length) xs
+
+toProse :: S.Schedule -> String
+toProse s =
+  mconcat
+    [ proseTime s.minute s.hour
+    , ", "
+    , proseDate s.dayOfMonth s.month s.dayOfWeek
+    ]
+
+proseDate :: E.Expr -> E.Expr -> E.Expr -> String
+proseDate dom mt dow = case (dom, mt, dow) of
+  (E.Every, E.Every, E.Every) -> "daily"
+  (E.Every, _, E.Every) -> "daily " ++ proseMonth mt
+  (E.Every, E.Every, E.Multi ns) -> "every " ++ listToProse (dayOfWeek <$> ns)
+  (E.Every, E.Every, E.Range _ _) -> proseDayOfWeek dow
+  (E.Every, _, E.Multi ns) -> "every " ++ listToProse (dayOfWeek <$> ns) ++ " " ++ proseMonth mt
+  (_, _, _) -> mconcat [proseDayOfMonth dom, " ", proseMonth mt, " ", proseDayOfWeek dow]
+ where
+  dayOfWeek m = showDayOfWeek m ?: "?"
+
+proseDayOfWeek :: E.Expr -> String
+proseDayOfWeek = \case
+  E.Every -> ""
+  E.Multi ns -> "on " ++ listToProse (dayOfWeek <$> ns)
+  E.Range n m -> mconcat ["from ", dayOfWeek n, " to ", dayOfWeek m]
+  E.Step E.StepLEvery 1 -> ""
+  E.Step E.StepLEvery n -> mconcat ["every ", show n, " days of the week"]
+  E.Step (E.StepLRange n m) j ->
+    mconcat
+      [ "every "
+      , show j
+      , " days of the week from "
+      , dayOfWeek n
+      , " to "
+      , dayOfWeek m
+      ]
+ where
+  dayOfWeek m = showDayOfWeek m ?: "?"
+
+proseMonth :: E.Expr -> String
+proseMonth = \case
+  E.Every -> "of every month"
+  E.Multi ns -> "of " ++ listToProse (month <$> ns)
+  E.Range n m -> mconcat ["from ", month n, " to ", month m]
+  E.Step E.StepLEvery 1 -> "of every month"
+  E.Step E.StepLEvery n -> mconcat ["of every ", show n, " months"]
+  E.Step (E.StepLRange n m) j ->
+    mconcat
+      [ "of every "
+      , show j
+      , " months from "
+      , month n
+      , " to "
+      , month m
+      ]
+ where
+  month m = showMonth m ?: "?"
+
+proseDayOfMonth :: E.Expr -> String
+proseDayOfMonth = \case
+  E.Every -> "daily"
+  E.Multi ns -> "on the " ++ listToProse (asOrdinal <$> ns)
+  E.Range n m -> mconcat ["daily from the ", asOrdinal n, " to the ", asOrdinal m]
+  E.Step E.StepLEvery 1 -> "daily"
+  E.Step E.StepLEvery n -> mconcat ["every ", show n, " days"]
+  E.Step (E.StepLRange n m) j ->
+    mconcat
+      [ "every "
+      , show j
+      , " days from the "
+      , asOrdinal n
+      , " to the "
+      , asOrdinal m
+      ]
+
+proseTime :: E.Expr -> E.Expr -> String
+proseTime mn h = case (mn, h) of
+  (E.Multi (0 :| []), E.Every) -> "At the top of every hour"
+  (E.Multi (0 :| []), E.Step E.StepLEvery 1) -> "At the top of every hour"
+  (E.Multi (n :| []), E.Multi (m :| [])) -> mconcat ["At ", leftPad 2 '0' $ show m, ":", leftPad 2 '0' $ show n]
+  (E.Multi (0 :| []), E.Multi ns) -> mconcat ["At the top of the ", listToProse (asOrdinal <$> ns), " hours"]
+  (_, E.Every) -> mconcat [proseMinute mn, " of every hour"]
+  (_, E.Step E.StepLEvery 1) -> mconcat [proseMinute mn, " of every hour"]
+  (_, _) -> mconcat [proseMinute mn, " ", proseHour h]
+
+proseHour :: E.Expr -> String
+proseHour = \case
+  E.Every -> "every hour"
+  E.Multi (n :| []) -> mconcat ["at hour ", leftPad 2 '0' $ show n]
+  E.Multi ns -> "at hours " ++ listToProse (show <$> ns)
+  E.Range n m -> mconcat ["every hour from ", leftPad 2 '0' $ show n, " to ", leftPad 2 '0' $ show m]
+  E.Step E.StepLEvery 1 -> "every hour"
+  E.Step E.StepLEvery n -> mconcat ["every ", show n, " hours"]
+  E.Step (E.StepLRange n m) j ->
+    mconcat
+      [ "every "
+      , show j
+      , " hours from "
+      , show n
+      , " to "
+      , show m
+      ]
+
+proseMinute :: E.Expr -> String
+proseMinute = \case
+  E.Every -> "Every minute"
+  E.Multi (n :| []) -> mconcat ["At minute ", leftPad 2 '0' $ show n]
+  E.Multi ns -> "At minutes " ++ listToProse (show <$> ns)
+  E.Range n m -> mconcat ["Every minute from ", leftPad 2 '0' $ show n, " to ", leftPad 2 '0' $ show m]
+  E.Step E.StepLEvery 1 -> "Every minute"
+  E.Step E.StepLEvery n -> mconcat ["every ", show n, " minutes"]
+  E.Step (E.StepLRange n m) j ->
+    mconcat
+      [ "every "
+      , show j
+      , " minutes from the "
+      , asOrdinal n
+      , " minute to the "
+      , asOrdinal m
+      , " minute"
+      ]
diff --git a/src/Cron/Expr.hs b/src/Cron/Expr.hs
new file mode 100644
index 0000000..a6cb4ca
--- /dev/null
+++ b/src/Cron/Expr.hs
@@ -0,0 +1,21 @@
+module Cron.Expr (Expr (..), StepLExpr (..), showExpr) where
+
+import Data.List.NonEmpty (NonEmpty, intersperse)
+import Data.Semigroup (sconcat)
+import Intro
+
+data Expr = Every | Multi (NonEmpty Int) | Range Int Int | Step StepLExpr Int deriving (Show)
+
+data StepLExpr = StepLEvery | StepLRange Int Int deriving (Show)
+
+showExpr :: Expr -> String
+showExpr = \case
+  Every -> "*"
+  Multi ns -> sconcat $ intersperse "," (fmap show ns)
+  Range n m -> mconcat [show n, "-", show m]
+  Step n m -> mconcat [showStepLExpr n, "/", show m]
+
+showStepLExpr :: StepLExpr -> String
+showStepLExpr = \case
+  StepLEvery -> "*"
+  StepLRange n m -> mconcat [show n, "-", show m]
diff --git a/src/Cron/Parser.hs b/src/Cron/Parser.hs
new file mode 100644
index 0000000..304a1e3
--- /dev/null
+++ b/src/Cron/Parser.hs
@@ -0,0 +1,88 @@
+module Cron.Parser (parse) where
+
+import Common (fromDigits)
+import Control.Applicative (Alternative, empty, liftA2, many, some, (*>), (<$), (<|>))
+import Control.Arrow (first, (>>>))
+import qualified Cron.Expr as E
+import Data.List.NonEmpty (NonEmpty ((:|)))
+import Intro
+import Text.Read (readMaybe)
+
+type Token = Char
+
+newtype Parser a = Parser {runParser :: [Token] -> Maybe (a, [Token])}
+
+instance Functor Parser where
+  fmap f (Parser p) = Parser (p >>> fmap (first f))
+
+instance Applicative Parser where
+  pure a = Parser (\input -> Just (a, input))
+  Parser pF <*> Parser pA = Parser $ \input -> do
+    (f, rest) <- pF input
+    (a, s) <- pA rest
+    pure (f a, s)
+
+instance Alternative Parser where
+  empty = Parser (const Nothing)
+  Parser pA <|> Parser pB = Parser $ \input -> case (pA input, pB input) of
+    (Nothing, expr) -> expr
+    (expr, _) -> expr
+
+match :: (Token -> Bool) -> Parser Token
+match p = Parser $ \case
+  t : ts | p t -> Just (t, ts)
+  _ -> Nothing
+
+token :: Token -> Parser Token
+token = (==) >>> match
+
+read :: (Token -> Maybe a) -> Parser a
+read f = Parser $ \case
+  t : ts -> case f t of
+    Just x -> Just (x, ts)
+    _ -> Nothing
+  _ -> Nothing
+
+sepBy1 :: Parser a -> Parser b -> Parser (NonEmpty a)
+sepBy1 p s = liftA2 (:|) p (many (s *> p))
+
+pair :: Parser a -> Parser b -> Parser c -> Parser (a, b)
+pair p1 p2 s = liftA2 (,) p1 (s *> p2)
+
+digit :: Parser Int
+digit = read $ \case
+  x | x `elem` ['0' .. '9'] -> readMaybe [x] :: Maybe Int
+  _ -> Nothing
+
+number :: Parser Int
+number = fromDigits <$> some digit
+
+--
+-- Cron Exprs
+--
+
+cRange :: Parser E.Expr
+cRange = uncurry E.Range <$> pair number number (token '-')
+
+cStepL :: Parser E.StepLExpr
+cStepL =
+  (E.StepLEvery <$ token '*')
+    <|> (uncurry E.StepLRange <$> pair number number (token '-'))
+
+cStep :: Parser E.Expr
+cStep = uncurry E.Step <$> pair cStepL number (token '/')
+
+cMulti :: Parser E.Expr
+cMulti = E.Multi <$> sepBy1 number (token ',')
+
+cEvery :: Parser E.Expr
+cEvery = E.Every <$ token '*'
+
+cExpr :: Parser E.Expr
+cExpr = cStep <|> cEvery <|> cRange <|> cMulti
+
+parse :: [Token] -> Either String E.Expr
+parse xs = case runParser cExpr xs of
+  Nothing -> Left "Invalid cron expression"
+  Just (expr, []) -> Right expr
+  Just (_, rest) -> Left ("Invalid cron expression. Couldn't parse `" ++ rest ++ "`")
diff --git a/src/Cron/Schedule.hs b/src/Cron/Schedule.hs
new file mode 100644
index 0000000..2ea56ab
--- /dev/null
+++ b/src/Cron/Schedule.hs
@@ -0,0 +1,72 @@
+module Cron.Schedule (Schedule (..), fromParts) where
+
+import Common ((?))
+import qualified Cron.Expr as E
+import qualified Cron.Parser as P
+import Intro
+
+data Schedule = Schedule
+  { minute :: E.Expr
+  , hour :: E.Expr
+  , dayOfMonth :: E.Expr
+  , month :: E.Expr
+  , dayOfWeek :: E.Expr
+  }
+  deriving (Show)
+
+fromParts :: String -> String -> String -> String -> String -> Either String Schedule
+fromParts mn h d m wd =
+  Schedule
+    <$> parseMinute mn
+    <*> parseHour h
+    <*> parseDayOfMonth d
+    <*> parseMonth m
+    <*> parseDayOfWeek wd
+
+parseMinute :: String -> Either String E.Expr
+parseMinute s = P.parse s >>= validateMinute
+
+parseHour :: String -> Either String E.Expr
+parseHour s = P.parse s >>= validateHour
+
+parseDayOfMonth :: String -> Either String E.Expr
+parseDayOfMonth s = P.parse s >>= validateDayOfMonth
+
+parseMonth :: String -> Either String E.Expr
+parseMonth s = P.parse s >>= validateMonth
+
+parseDayOfWeek :: String -> Either String E.Expr
+parseDayOfWeek s = P.parse s >>= validateDayOfWeek
+
+validateMinute :: E.Expr -> Either String E.Expr
+validateMinute expr = validateExpr expr >>= flip validateInRange [0 .. 59]
+
+validateHour :: E.Expr -> Either String E.Expr
+validateHour expr = validateExpr expr >>= flip validateInRange [0 .. 23]
+
+validateDayOfMonth :: E.Expr -> Either String E.Expr
+validateDayOfMonth expr = validateExpr expr >>= flip validateInRange [1 .. 31]
+
+validateMonth :: E.Expr -> Either String E.Expr
+validateMonth expr = validateExpr expr >>= flip validateInRange [1 .. 12]
+
+validateDayOfWeek :: E.Expr -> Either String E.Expr
+validateDayOfWeek expr = validateExpr expr >>= flip validateInRange [0 .. 6]
+
+validateExpr :: E.Expr -> Either String E.Expr
+validateExpr expr = validate expr $ \case
+  E.Range n m -> n < m
+  _ -> True
+
+validateInRange :: E.Expr -> [Int] -> Either String E.Expr
+validateInRange expr range = validate expr $ \case
+  E.Multi ns -> all inRange ns
+  E.Range n m -> inRange n && inRange m
+  E.Step _ _ -> True
+  E.Every -> True
+ where
+  inRange :: Int -> Bool
+  inRange = flip elem range
+
+validate :: E.Expr -> (E.Expr -> Bool) -> Either String E.Expr
+validate expr p = p expr ? Right expr $ Left ("Invalid cron expression " ++ E.showExpr expr)
diff --git a/src/Intro.hs b/src/Intro.hs
new file mode 100644
index 0000000..b6c76b7
--- /dev/null
+++ b/src/Intro.hs
@@ -0,0 +1,64 @@
+module Intro
+  ( ($)
+  , (&&)
+  , (*)
+  , (+)
+  , (++)
+  , (-)
+  , (.)
+  , (/=)
+  , (<$>)
+  , (<*>)
+  , (<)
+  , (=<<)
+  , (==)
+  , (>>=)
+  , (||)
+  , Applicative
+  , Bool (False, True)
+  , Char
+  , Eq
+  , IO
+  , Int
+  , Maybe (Just, Nothing)
+  , Either (Left, Right)
+  , Functor
+  , Show
+  , String
+  , all
+  , break
+  , concat
+  , const
+  , curry
+  , dropWhile
+  , either
+  , elem
+  , filter
+  , flip
+  , foldl
+  , foldr
+  , fst
+  , head
+  , init
+  , last
+  , length
+  , fmap
+  , id
+  , mconcat
+  , mod
+  , not
+  , otherwise
+  , pure
+  , putStrLn
+  , reverse
+  , show
+  , snd
+  , uncurry
+  , words
+  , zip
+  , zipWith
+  , null
+  )
+where
+
+import Prelude