The boss wants more
So the boss comes back and says, “Naren, this is great but I don’t want to write code to specify my schedule”. He scribbles some notes on the whiteboard to illustrate that he’d rather specify his schedules in plain text.
Meeting with CTO
Mo, We,Fr 10-12, 3-5
Lunch
Mo,Tu,We,Th,Fr 12-1
Amazingly, your colleague has a parser
You don’t scramble into a panic because your best pal already has a parser created and it reads as follows. Some imports;
> {-# LANGUAGE OverloadedStrings #-}
> module CoverPart2 where
> import CoverPart1
> import SchedulePrimitives
> import Prelude hiding (takeWhile)
> import Control.Applicative
> import Control.Monad
> import Data.Attoparsec.Text
> import Data.Attoparsec.Combinator
> import Data.Char
> import Data.Functor.Compose
> import Data.Text (Text,unpack,pack)
a few individual parsers for the label, the day of week, and time range components;
> label :: Parser Text
> label = skipSpace *> takeWhile1 (\c -> not (isEndOfLine c) && (isAlphaNum c || isSpace c)) <* endOfLine
>
> dayOfWeekP :: Parser Text
> dayOfWeekP = skipSpace *> choice ["Mo","Tu","We","Th","Fr","Sa","Su"]
>
> hourRangeP :: Parser (Int,Int)
> hourRangeP = do
> skipSpace
> x <- decimal
> guard (x >= 0 && x <= 23)
> char '-'
> y <- decimal
> guard (y >= 0 && y <= 23 && x < y)
> return (x,y)
and, in keeping with good coding, a full parser is created using combinations of the above.
> schedule :: Parser [(Text,[Text],[(Int,Int)])]
> schedule = many $
> (,,)
> <$> label
> <*> (dayOfWeekP `sepBy1` (skipSpace *> char ','))
> <*> (hourRangeP `sepBy1` (skipSpace *> char ','))
You try it out.
> sched1 :: Text
> sched1 = "Meet with CTO\n\
> \Mo,We,Fr 10-12, 15-16\n\
> \\n\
> \Lunch\n\
> \Mo,Tu,We,Tu,Fr 12-13"
ghci> let Right s = parseOnly schedule sched1
ghci> mapM_ print s
("Meet with CTO",["Mo","We","Fr"],[(10,12),(15,16)])
("Lunch",["Mo","Tu","We","Tu","Fr"],[(12,13)])
I don’t want to write another interpreter!
Nice. Technically, you could write a converter to take the output of this parser and convert it to a schedule. That’s just a whole lot of double work. Because, you essentially end up writing another parser – only this time, it parses a data structure. So, let’s have a look at our humble friend from the last post that allowed us to hang IO actions within a Schedule DT. Surely, what we want is to hang Schedule DT within a Parser!
> type ParserS = Compose Parser (Schedule DT)
>
> (<$$>) :: (b -> Schedule DT a) -> Parser b -> ParserS a
> f <$$> p = Compose $ f <$> p
>
> liftP :: Parser a -> ParserS a
> liftP = (<$$>) pure
Here’s the new schedule parser,
> scheduleS :: ParserS [Text]
> scheduleS = fmap (foldr (++) []) . many $
> (\l a b -> if a && b then [l] else [])
> <$> liftP label
> <*> fmap or (dayOfWeekS `sepBy1` (liftP $ skipSpace *> char ','))
> <*> fmap or (hourRangeS `sepBy1` (liftP $ skipSpace *> char ','))
> where dayOfWeekS = (fmap (snd.fst) . dayOfWeek . unpack) <$$> dayOfWeekP
> hourRangeS = (uncurry hourRange) <$$> hourRangeP
>
> hourRange :: Int -> Int -> Schedule DT Bool
> hourRange i j = (\(_,(a,_)) (_,(b,_)) -> a > b)
> <$> arbitraryRange (fromIntegral i*3600) (24*3600)
> <*> arbitraryRange (fromIntegral j*3600) (24*3600)
et voila!
ghci> let Right s = parseOnly (getCompose scheduleS) sched1
ghci> :t s
s :: Schedule DT [Text]
ghci> pretty . filter (not . null . fst) $ runSchedule s (0,7*24*3600)
(1970-01-02 10:00:00 UTC,1970-01-02 11:59:59 UTC) ---> ["Meet with CTO"]
(1970-01-02 12:00:00 UTC,1970-01-02 12:59:59 UTC) ---> ["Lunch"]
(1970-01-02 15:00:00 UTC,1970-01-02 15:59:59 UTC) ---> ["Meet with CTO"]
(1970-01-05 10:00:00 UTC,1970-01-05 11:59:59 UTC) ---> ["Meet with CTO"]
(1970-01-05 12:00:00 UTC,1970-01-05 12:59:59 UTC) ---> ["Lunch"]
(1970-01-05 15:00:00 UTC,1970-01-05 15:59:59 UTC) ---> ["Meet with CTO"]
(1970-01-06 12:00:00 UTC,1970-01-06 12:59:59 UTC) ---> ["Lunch"]
(1970-01-07 10:00:00 UTC,1970-01-07 11:59:59 UTC) ---> ["Meet with CTO"]
(1970-01-07 12:00:00 UTC,1970-01-07 12:59:59 UTC) ---> ["Lunch"]
(1970-01-07 15:00:00 UTC,1970-01-07 15:59:59 UTC) ---> ["Meet with CTO"]
There are no problems with overlapping events either.
> sched2 :: Text
> sched2 = "Meet with CTO\n\
> \Mo,We,Fr 11-13, 15-16\n\
> \\n\
> \Lunch\n\
> \Mo,Tu,We,Tu,Fr 12-13"
ghci> let Right s = parseOnly (getCompose scheduleS) sched2
ghci> pretty . filter (not . null . fst) $ runSchedule s (0,7*24*3600)
(1970-01-02 11:00:00 UTC,1970-01-02 11:59:59 UTC) ---> ["Meet with CTO"]
(1970-01-02 12:00:00 UTC,1970-01-02 12:59:59 UTC) ---> ["Meet with CTO","Lunch"]
(1970-01-02 15:00:00 UTC,1970-01-02 15:59:59 UTC) ---> ["Meet with CTO"]
(1970-01-05 11:00:00 UTC,1970-01-05 11:59:59 UTC) ---> ["Meet with CTO"]
(1970-01-05 12:00:00 UTC,1970-01-05 12:59:59 UTC) ---> ["Meet with CTO","Lunch"]
(1970-01-05 15:00:00 UTC,1970-01-05 15:59:59 UTC) ---> ["Meet with CTO"]
(1970-01-06 12:00:00 UTC,1970-01-06 12:59:59 UTC) ---> ["Lunch"]
(1970-01-07 11:00:00 UTC,1970-01-07 11:59:59 UTC) ---> ["Meet with CTO"]
(1970-01-07 12:00:00 UTC,1970-01-07 12:59:59 UTC) ---> ["Meet with CTO","Lunch"]
(1970-01-07 15:00:00 UTC,1970-01-07 15:59:59 UTC) ---> ["Meet with CTO"]
Next time
I’ve often been under the impression that Applicative’s are pretty boring; I tend to spend no time with them as I tuck into Monads straight way; so, I’ll leave myself and you, the reader, with a collection of great blog-posts and Haskell libraries on this topic that are well worth the read. Next time, I’ll go back to the problem of leap years and general constraint specification.
- Gabriel Gonzalez: Using Applicative and Alterative to model database table joins
- A masterclass (using folds) not only in Applicative but also in treating computations as primitives:
- Conal Elliott: Another lovely example of type class morphisms
- Conal Elliott: More beautiful fold zipping
- Gabriel’s post: Composable streaming folds
- Paolo Capriotti: Applicative is thoroughly embraced in this package
- Of course, I can’t list posts on abstractions without Mr. Edward Kmett’s input on this matter: Abstracting With Applicatives
There are many more in the back of my head; I’ll add them here as I recall them. Meanwhile, please leave your links in the comments below!
Latent observations 