1 {-# LANGUAGE TemplateHaskell #-}
    2 {-# OPTIONS_GHC -fno-warn-orphans #-}
    3 module Databrary.Model.Time
    4   ( Date
    5   , Timestamp
    6   , dateYear
    7   , MaskedDate
    8   , maskDateIf
    9   , maskedYear
   10   ) where
   11 
   12 import qualified Data.Aeson as JSON
   13 import Data.Fixed (Fixed(..))
   14 import Data.Time (Day(..), UTCTime(..), DiffTime, toGregorian, fromGregorian)
   15 import Data.Time.Format (FormatTime(..), formatTime, dateFmt)
   16 import Language.Haskell.TH.Lift (deriveLiftMany)
   17 
   18 -- | Synomym for a Day
   19 type Date = Day
   20 -- | Synonym for a UTCTime
   21 type Timestamp = UTCTime
   22 
   23 deriveLiftMany [''Fixed, ''DiffTime, ''Day, ''UTCTime]
   24 
   25 data MaskedDate
   26   = MaskedDate !Int
   27   | UnmaskedDate !Date
   28 
   29 -- | Extract year part of a date value
   30 dateYear :: Date -> Int
   31 dateYear d = fromInteger y where (y,_,_) = toGregorian d
   32 
   33 -- | Mask a date value by only keeping the year portion
   34 maskDate :: Date -> MaskedDate
   35 maskDate = MaskedDate . dateYear
   36 
   37 -- | Lift a raw date value into a MaskedDate (either actually masked or unmasked)
   38 maskDateIf :: Bool -> Date -> MaskedDate
   39 maskDateIf True = maskDate
   40 maskDateIf False = UnmaskedDate
   41 
   42 -- | Extract year from a potentially masked date value
   43 maskedYear :: MaskedDate -> Int
   44 maskedYear (MaskedDate y) = y
   45 maskedYear (UnmaskedDate d) = dateYear d
   46 
   47 -- | Provide behavior to hook into general date formatting utilities
   48 instance FormatTime MaskedDate where
   49   formatCharacter 'D' = Just (\locale _ -> formatTime locale "%m/%d/%y")
   50   formatCharacter 'F' = Just (\locale _ -> formatTime locale "%Y-%m-%d")
   51   formatCharacter 'x' = Just (\locale _ -> formatTime locale (dateFmt locale))
   52   formatCharacter c = f <$> formatCharacter c where
   53     f g l o (UnmaskedDate d) = g l o d
   54     f g l o (MaskedDate y)
   55       | c `elem` "YyCGgf" = r
   56       | otherwise = map (const 'X') r
   57       where r = g l o $ fromGregorian (toInteger y) 11 21
   58 
   59 instance JSON.ToJSON MaskedDate where
   60   toJSON (MaskedDate y) = JSON.toJSON y
   61   toJSON (UnmaskedDate d) = JSON.toJSON d