optics for things like div mods

divModIso.hs

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

import Control.Lens -- (over)
import Data.Time

---------------- month as year + month ------------------------

data Month = Month
  { month_year :: Int
  , month_month :: Int
  }
  deriving (Show, Eq, Ord)

newtype Hour = Hour Int
  deriving (Eq, Ord, Show, Enum, Num)

class DivMod a b where
  type DivModRem a b
  divModIso :: Iso' (a, DivModRem a b) b
  divModZero :: DivModRem a b

-- | DivModIso imply a back lens on the floor
divModLens :: DivMod a b => Lens' b a
divModLens = from divModIso . _1

-- | DivModIso implies a back lens on a reminder,
-- weak , needs an annotation to resolve 'a'
divModRem :: forall a b. DivMod a b => Lens' b (DivModRem a b)
divModRem = from (divModIso @a) . _2

-- | DivModIso implies a prism based on reminder equality   to its zero
divModPrism :: forall a b. (Eq (DivModRem a b)) => DivMod a b => Prism' b a
divModPrism = prism'
  do \h -> (h, divModZero @a @b) ^. divModIso
  do
    \u ->
      if u ^. divModRem @a == divModZero @a @b
        then Just $ u ^. divModLens
        else Nothing

-- | Promotes a 'a' to a floor in 'b'
divModFloor :: (Eq (DivModRem a b), DivMod a b) => Getter a b
divModFloor = re divModPrism

---------------- month and days ------------------------

instance DivMod Month Day where
  type DivModRem Month Day = Int
  divModIso = iso
    do \(Month y m, d) -> fromGregorian (fromIntegral y) m d
    do
      \day ->
        let (year, month', day') = toGregorian day
         in (Month (fromIntegral year) month', day')
  divModZero = 1

---------------- hour and utc ------------------------
instance DivMod Hour UTCTime where
  type DivModRem Hour UTCTime = DiffTime
  divModIso = iso
    do
      \(Hour h, seconds) ->
        let (days, hours) = divMod h 24
         in UTCTime (toEnum days) $ fromIntegral (hours * 3600) + seconds
    do
      \(UTCTime day seconds) ->
        let (hours, left) = properFraction $ seconds / 3600
         in (Hour $ fromEnum day * 24 + hours, left * 3600)
  divModZero = 0

---------------- day and utc  ------------------------

instance DivMod Day UTCTime where
  type DivModRem Day UTCTime = DiffTime
  divModIso = iso
    do uncurry UTCTime
    do \(UTCTime day seconds) -> (day, seconds)
  divModZero = 0


---------------- application ------------------------

main :: IO ()
main =
  do
    let p x y = putStr (x <> ": ") >> print y
    u :: UTCTime <- parseTimeM True defaultTimeLocale "%F %R" "2020-07-04 12:10"
    p "current time" u
    p "current day" $ u ^. divModLens @Day
    p "current hour" $ u ^. divModLens @Hour
    p "current month" $
      u ^. divModLens @Day
        ^. divModLens @Month
    p
      "first day of this month"
      $ u ^. divModLens @Day
        ^. divModLens @Month
        ^. divModFloor @Month @Day
    p
      "number of days since the beginning of this month"
      $ u ^. divModLens @Day
        ^. divModRem @Month @Day