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
112
113
114
|
{-# LANGUAGE TemplateHaskell, GADTs, RankNTypes, DataKinds, ViewPatterns, ScopedTypeVariables, FlexibleContexts, FlexibleInstances, UndecidableInstances, TypeFamilies #-}
module Postdelay.TimeSpec.Units
( Time
, Second(..), Minute(..), Hour(..)
, Day(..), Week(..), Month(..), Year(..)
, timeLength
, module Data.Metrology
, module Data.Units.SI.Prefixes
) where
import Postdelay.TimeSpec.Utils
import Control.Applicative
import Control.Monad
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
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 (boundedRational False $ 0 <=..< PosInf) <*> timeUnit <?> "Length of time"
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"
]
, option 1 siPrefix <**> choice [ (% Second) <$ string "s"
, (% Hour ) <$ string "h"
, (% Day ) <$ string "d"
, (% Year ) <$ choice [ string "a", string' "yr", string' "yrs" ]
]
]
data Prefix where
Prefix :: forall p. ParseablePrefix p => p -> Prefix
class UnitPrefix a => ParseablePrefix a where
parser :: StringParser s m => a -> m ()
instance {-# OVERLAPPABLE #-} (UnitPrefix a, Show a) => ParseablePrefix a where
parser = void . string . show
instance ParseablePrefix Micro where
parser _ = void $ choice [ string "µ", string "u" ]
siPrefix :: (StringParser s m, Fractional n) => m n
siPrefix = label "SI prefix" . choice $ map (\(Prefix p) -> multiplier p <$ parser 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
]
|
