1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
|
{-# LANGUAGE TemplateHaskell, TypeFamilies, GADTs, RankNTypes, DataKinds, ViewPatterns, ScopedTypeVariables #-}
module Postdelay.TimeSpec.Units
( Time
, Second, Minute, Hour
, Day, Week, Month, Year
, timeLength
, module Data.Units.SI.Prefixes
) where
import Postdelay.TimeSpec.Utils
import Control.Applicative
import Data.Metrology
import Data.Metrology.TH
import Data.Metrology.SI.Mono ()
import Data.Units.SI
import Data.Units.SI.Prefixes
import Data.Units.SI.Parser
import qualified Data.Dimensions.SI as D
import Data.Foldable
import Data.Function
import Data.VectorSpace
import Data.Fixed (Fixed, HasResolution)
import qualified Data.Fixed as Fixed
import Text.Megaparsec
declareDerivedUnit "Day" [t| Hour |] 24 Nothing
declareDerivedUnit "Week" [t| Day |] 7 Nothing
declareDerivedUnit "Month" [t| Day |] 30 Nothing
declareDerivedUnit "Year" [t| Day |] 365.25 Nothing
type Time = MkQu_DLN D.Time DefaultLCSU Fixed.Pico
data Prefix where
Prefix :: forall p. (UnitPrefix p, Show p) => p -> Prefix
instance HasResolution p => AdditiveGroup (Fixed p) where
zeroV = 0
(^+^) = (+)
negateV = negate
(^-^) = (-)
instance HasResolution p => VectorSpace (Fixed p) where
type Scalar (Fixed p) = Fixed p
(*^) = (*)
timeLength :: StringParser s m => m Time
timeLength = (*^) <$> lexeme rational <*> timeUnit
rational :: forall s m n. (StringParser s m, Fractional n, Num n) => m n
rational = combine <$> some digitChar <*> option [] (char '.' *> many digitChar)
where
combine :: [Char] -> [Char] -> n
combine (map asN -> whole) (map asN -> fractional)
= foldl' (\i l -> i * 10 + l) 0 whole + (foldr' (\h t -> h + t / 10) 0 fractional) / 10
asN :: Char -> n
asN c = fromIntegral $ ((-) `on` fromEnum) c '0'
timeUnit :: StringParser s m => m Time
timeUnit = label "Unit of time" . choice $
[ 1 % Second <$ choice [ string' "seconds"
, string' "second"
, string' "secs"
, string' "sec"
]
, 1 % Minute <$ choice [ string' "minutes"
, string' "minute"
, string' "mins"
, string' "min"
]
, 1 % Hour <$ choice [ string' "hours"
, string' "hour"
]
, 1 % Day <$ choice [ string' "days"
, string' "day"
]
, 1 % Week <$ choice [ string' "weeks"
, string' "week"
]
, 1 % Month <$ choice [ string' "months"
, string' "month"
]
, 1 % Year <$ choice [ string' "years"
, string' "year"
]
] ++
[ (% Second) <$> option 1 siPrefix <* string "s"
, (% Hour) <$> option 1 siPrefix <* string "h"
, (% Day) <$> option 1 siPrefix <* string "d"
, (% Year) <$> option 1 siPrefix <* choice [ string "a", string "yr", string "yrs" ]
]
siPrefix :: (StringParser s m, Fractional n) => m n
siPrefix = label "SI prefix" . choice $ map (\(Prefix p) -> multiplier p <$ string (show p))
[ Prefix Deca, Prefix Hecto, Prefix Kilo, Prefix Mega, Prefix Giga
, Prefix Tera, Prefix Peta, Prefix Exa, Prefix Zetta, Prefix Yotta
, Prefix Deci, Prefix Centi, Prefix Milli, Prefix Micro, Prefix Nano
, Prefix Pico, Prefix Femto, Prefix Atto, Prefix Zepto, Prefix Yocto
]
|
