Haskell Abstractions At Work (Part II – An Interlude)

View literate file on Github

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.

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!

Advertisements
This entry was posted in Haskell and tagged , , , . Bookmark the permalink.

Leave a Reply

Fill in your details below or click an icon to log in:

WordPress.com Logo

You are commenting using your WordPress.com account. Log Out / Change )

Twitter picture

You are commenting using your Twitter account. Log Out / Change )

Facebook photo

You are commenting using your Facebook account. Log Out / Change )

Google+ photo

You are commenting using your Google+ account. Log Out / Change )

Connecting to %s