1
\$\begingroup\$

Happily picked up Haskell a couple days back and working on the following use case.

Given a list of JSON objects with date fields and a start date, I want to create a list of weeks (here a tuple of dates, but improvements are welcome) from the start date to today plus a week, and count the number of days from the JSON that fall within each week.

{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}

import Data.Aeson
import GHC.Generics
import Network.HTTP.Conduit (simpleHttp)
import Data.Text (Text, intercalate)
import Data.Time
import Data.Time.Clock.POSIX
import Data.Map (Map, fromList, toList, insert, lookup)
import qualified Data.ByteString.Lazy as BSL
import qualified Data.ByteString.Internal as BSI

parseDate str = utctDay $ parseTimeOrError True defaultTimeLocale "%d/%m/%Y" str :: Day

type DateRange = (Day, Day)
type DateRangeCount = (DateRange, Int)

_makeRanges :: Day -> Day -> [DateRange] -> [DateRange]
_makeRanges currDate endDate ranges
  | currDate <= endDate =
      let endRangeDate = addDays 6 currDate
          newCurrDate = addDays 1 endRangeDate
      in (currDate, endRangeDate) : _makeRanges newCurrDate endDate ranges 
  | otherwise = ranges

createRanges :: String -> UTCTime  -> [DateRange]
createRanges startDateString endTime =
  let startDate = parseDate startDateString
      endDate = utctDay endTime
  in _makeRanges startDate endDate []

isDayInRange :: Day -> DateRange -> Bool
isDayInRange day range = day >= fst range && day <= snd range

findRange :: Day -> ([DateRange] -> [DateRange])
findRange day = filter $ isDayInRange day

incrementCount :: [DateRange] -> Map DateRange Int -> Person -> Map DateRange Int
incrementCount ranges countMap person =
  let range = head $ findRange (date person) ranges
  in case Data.Map.lookup range countMap of
      Just i -> insert range (i+1) countMap
      Nothing -> countMap

countPersons :: [Person] -> [DateRange] -> Map DateRange Int
countPersons persons ranges =
  let countMap = fromList $ map (, 0) ranges
  in foldl (incrementCount ranges) countMap persons

newtype Person =
  Person {date :: Day} deriving (Show, Generic)

instance FromJSON Person where
 parseJSON (Object o) = do
    dateString <- o .: "date"
    return Person {date = parseDate dateString}

getData :: Maybe String -> IO (Either String [Person])
getData url = case url of
  Just url -> eitherDecode <$> simpleHttp url
  Nothing -> return (eitherDecode <$> BSL.pack $ map BSI.c2w "[{\"date\":\"21/05/2021\"},{\"date\":\"01/06/2021\"}]")

main :: IO ()
main = do
    -- r <- getData $ Just "gg" 
    r <- getData Nothing
    case r of
        Left err -> putStrLn err
        Right persons -> do
          endTime <- getCurrentTime
          let ranges = createRanges "01/05/2021" endTime
              counts = countPersons persons ranges
          mapM_ print $ toList counts
          print $ sum counts

Current input "01/05/2021", the output is:

((2021-05-01,2021-05-07),0)
((2021-05-08,2021-05-14),0)
((2021-05-15,2021-05-21),1)
((2021-05-22,2021-05-28),0)
((2021-05-29,2021-06-04),1)
((2021-06-05,2021-06-11),0)
2

Bonus question if it's allowed: I also want to type Map DateRange Int as DateRangeCountMap, but this messes with fromList's expected type which is the raw Map. Any ideas?

\$\endgroup\$

0

Reset to default

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.