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